From 86e387d05729dda6366c695aa6518238a2c1ea80 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Thu, 15 Apr 2010 21:04:26 -0400 Subject: [PATCH] 1.702: fix to traverse, broken in 1.700. do-first operations must appear before module operations. Do it in two passes. Appending N times is evil. --- asdf.lisp | 144 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 80 insertions(+), 64 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index c50cde6c..4917fd82 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -63,7 +63,7 @@ (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) (let* ((asdf-version ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace - (subseq "VERSION:1.701" (1+ (length "VERSION")))) + (subseq "VERSION:1.702" (1+ (length "VERSION")))) (existing-asdf (find-package :asdf)) (versym '#:*asdf-version*) (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf))) @@ -431,9 +431,9 @@ processed in order by `operate`.")) (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) - (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v))) collectors vars) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) ,@body - (values ,@(mapcar #'(lambda (v) `(nreverse ,v)) vars)))))) + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) @@ -1204,7 +1204,7 @@ to `~a` which is not a directory.~@:>" (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) - (visiting-nodes :initform nil :accessor operation-visiting-nodes) + (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) @@ -1270,15 +1270,13 @@ class specifier, not an operation." (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal)))) - new-value) + (setf (gethash node (operation-visiting-nodes a)) t) + (remhash node (operation-visiting-nodes a))) + new-value)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (node-for o c))) - (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + (gethash node (operation-visiting-nodes (operation-ancestor o))))) (defmethod component-depends-on ((op-spec symbol) (c component)) (component-depends-on (make-instance op-spec) c)) @@ -1456,6 +1454,9 @@ recursive calls to traverse.") (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d)))))) flag)))) +(defun do-collect (collect x) + (funcall collect x)) + (defmethod do-traverse ((operation operation) (c component) collect) (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? (labels @@ -1464,7 +1465,7 @@ recursive calls to traverse.") (setf flag t))) (dep (op comp) (update-flag (do-dep operation c collect op comp)))) - ;; Have we been visited yet? If so, just process the result? + ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) (progn (update-flag (cdr it)) @@ -1485,55 +1486,59 @@ recursive calls to traverse.") :for (required-op . deps) :in (component-depends-on operation c) :do (dep required-op deps))) ;; constituent bits - (when (typep c 'module) - (let ((at-least-one nil) - ;; This is set based on the results of the - ;; dependencies and whether we are in the - ;; context of a *forcing* call... - ;; inter-system dependencies do NOT trigger - ;; building components - (*forcing* - (or *forcing* - (and flag (not (typep c 'system))))) - (error nil)) - (dolist (kid (module-components c)) - (handler-case - (do-traverse operation kid collect) - (missing-dependency (condition) - (when (eq (module-if-component-dep-fails c) - :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) - :try-next) - (not at-least-one)) - (error error)))) - (update-flag - (or - *forcing* - (not (operation-done-p operation c)) - ;; For sub-operations, check whether - ;; the original ancestor operation was forced, - ;; or names us amongst an explicit list of things to force... - ;; except that this check doesn't distinguish - ;; between all the things with a given name. Sigh. - ;; BROKEN! - (let ((f (operation-forced - (operation-ancestor operation)))) - (and f (or (not (consp f)) ;; T or :ALL - (and (typep c 'system) ;; list of names of systems to force - (member (component-name c) f - :test #'string=))))))) - (when flag - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (component-do-first c))))) - (loop :for (required-op . deps) :in do-first - :do (do-dep operation c collect required-op deps))) - (funcall collect (cons operation c)))) - (setf (visiting-component operation c) nil))) + (let ((module-ops + (when (typep c 'module) + (let ((at-least-one nil) + ;; This is set based on the results of the + ;; dependencies and whether we are in the + ;; context of a *forcing* call... + ;; inter-system dependencies do NOT trigger + ;; building components + (*forcing* + (or *forcing* + (and flag (not (typep c 'system))))) + (error nil)) + (while-collecting (internal-collect) + (dolist (kid (module-components c)) + (handler-case + (update-flag + (do-traverse operation kid #'internal-collect)) + (missing-dependency (condition) + (when (eq (module-if-component-dep-fails c) + :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) + :try-next) + (not at-least-one)) + (error error))))))) + (update-flag + (or + *forcing* + (not (operation-done-p operation c)) + ;; For sub-operations, check whether + ;; the original ancestor operation was forced, + ;; or names us amongst an explicit list of things to force... + ;; except that this check doesn't distinguish + ;; between all the things with a given name. Sigh. + ;; BROKEN! + (let ((f (operation-forced + (operation-ancestor operation)))) + (and f (or (not (consp f)) ;; T or :ALL + (and (typep c 'system) ;; list of names of systems to force + (member (component-name c) f + :test #'string=))))))) + (when flag + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (component-do-first c))))) + (loop :for (required-op . deps) :in do-first + :do (do-dep operation c collect required-op deps))) + (do-collect collect (vector module-ops)) + (do-collect collect (cons operation c))))) + (setf (visiting-component operation c) nil))) (visit-component operation c flag) flag)) @@ -1545,8 +1550,19 @@ recursive calls to traverse.") "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") (setf (operation-forced operation) (mapcar #'coerce-name (operation-forced operation)))) - (while-collecting (collect) - (do-traverse operation c #'collect))) + (flatten-tree + (while-collecting (collect) + (do-traverse operation c #'collect)))) + +(defun flatten-tree (l) + (while-collecting (c) + (labels ((r (x) + (if (vectorp x) + (r* (svref x 0)) + (c x))) + (r* (l) + (dolist (x l) (r x)))) + (r* l)))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -2032,8 +2048,8 @@ Returns the new tree (which probably shares structure with the old one)" (union-of-dependencies in-order-to `((compile-op (compile-op ,@depends-on)) - (load-op (load-op ,@depends-on)))) - (component-do-first ret) `((compile-op (load-op ,@depends-on)))) + (load-op (load-op ,@depends-on))))) + (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) (%refresh-component-inline-methods ret rest) ret))) -- GitLab