From 3a1b88bb2723e3345ead93082005d6eba49b1a77 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Thu, 15 Apr 2010 19:13:30 -0400
Subject: [PATCH] 1.700: big rewrite of TRAVERSE. * split traverse into
 multiple functions. * don't append things all over traverse, use a collector
 function * don't insert and remove prune-op to indicate something needs be
 done  even when the collected list is empty... use a boolean flag in all
 cases. * fix the age-old broken :force (system1 ... system2) feature... with
 a cerror! * fix the age-old broken (:feature :foo dependency) feature... with
 a cerror! * tighten :version syntax to only accept the keyword, not any
 same-named symbol. * use hash-tables for O(1) access where linear search was
 previously used,  notably in visited-nodes and in components-by-name. * use
 more uniform #+ features for windows. * modify defclass to make POIU happier
 (hopefully). * factor probe-asd out of sysdef-source-registry-search and
 sysdef-central-registry-search * fix safe-file-write-date, which I had
 previously broken when accepting a null pathname. * have serial-depends-on
 only name the previous thing to depend on.

Passes tests on sbcl, clisp, ecl, lispworks, allegro.
Fails on gclcvs: bind stack overflow. Is that a regression?

small website updates.
---
 GNUmakefile       |   8 +-
 asdf.lisp         | 563 ++++++++++++++++++++++++----------------------
 doc/.htaccess     |   1 +
 doc/Makefile      |   4 +-
 doc/asdf.texinfo  |   3 +
 doc/manual.html   |  10 -
 test/test1.script |   3 +-
 test/test2b1.asd  |   2 +-
 test/test2b2.asd  |   2 +-
 test/test2b3.asd  |   2 -
 10 files changed, 314 insertions(+), 284 deletions(-)
 create mode 100644 doc/.htaccess
 delete mode 100644 doc/manual.html

diff --git a/GNUmakefile b/GNUmakefile
index d2d4117f..ad952fd3 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -21,7 +21,6 @@ bump_revision: FORCE
 	bin/bump-revision-and-tag.sh
 
 archive: FORCE
-
 	sbcl --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
 		--eval "(rewrite-license)" --eval "(quit)"
 	bin/build-tarball.sh
@@ -33,9 +32,8 @@ archive-copy: archive
 	git push cl.net
 	git push --tags cl.net
 
-website-copy: FORCE
-	bin/rsync-cp.sh website/output/ $(webhome_private)
-	bin/rsync-cp.sh tmp/asdf.lisp $(webhome_private)
+website:
+	make -C doc website
 
 clean_dirs = $(sourceDirectory)
 clean_extensions = fasl dfsl cfsl fasl fas lib dx32fsl lx64fsl lx32fsl o bak
@@ -52,6 +50,8 @@ clean: FORCE
 		done; \
 	     fi; \
 	done
+	rm -rf tmp
+	make -C doc clean
 
 test: FORCE
 	@cd test; make clean;./run-tests.sh $(lisp) $(test-regex)
diff --git a/asdf.lisp b/asdf.lisp
index a3cbbeeb..8881b0d4 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -51,17 +51,19 @@
 
 (declaim (optimize (speed 2) (debug 2) (safety 3)))
 
-#+ecl (require 'cmp)
+#+ecl (require :cmp)
 
 ;;;; Create packages in a way that is compatible with hot-upgrade.
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
 ;;;; See more at the end of the file.
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
+  #+allegro
+  (setf excl::*autoload-package-name-alist*
+        (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.679" (1+ (length "VERSION"))))
-         #+allegro (excl::*autoload-package-name-alist* nil)
+          (subseq "VERSION:1.700" (1+ (length "VERSION"))))
          (existing-asdf (find-package :asdf))
          (versym '#:*asdf-version*)
          (existing-version (and existing-asdf (find-symbol (string versym) existing-asdf)))
@@ -200,6 +202,7 @@
            #:unix-dso
 
            #:module-components          ; component accessors
+           #:module-components-by-name  ; component accessors
            #:component-pathname
            #:component-relative-pathname
            #:component-name
@@ -265,7 +268,8 @@
            #:clear-source-registry
            #:ensure-source-registry
            #:process-source-registry))
-        (eval `(defparameter ,(intern (string versym) (find-package :asdf)) ,asdf-version))))))
+        (eval `(defparameter ,(intern (string versym) (find-package :asdf))
+                 ,asdf-version))))))
 
 (in-package #:asdf)
 
@@ -307,6 +311,12 @@ Defaults to `t`.")
 ;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
 ;;;;   for each of the classes we define that has changed incompatibly.
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-class 'module nil)
+    (eval ;; without this protection, Lispworks issues a warning. Sigh.
+     '(defmethod update-instance-for-redefined-class :after
+       ((m module) added deleted plist &key)
+       (when (member 'components-by-name added)
+         (compute-module-components-by-name m)))))
   #+ecl
   (when (find-class 'compile-op nil)
     (defmethod update-instance-for-redefined-class :after
@@ -365,7 +375,7 @@ VISIT-COMPONENT, if that has been called, otherwise NIL.
 This value stored will be a cons cell, the first element
 of which is a computed key, so not interesting.  The
 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as \(cdr \(component-visited-p op c\)\).
+it as (cdr (component-visited-p op c)).
   In the current form of ASDF, the DATA value retrieved is
 effectively a boolean, indicating whether some operations are
 to be performed in order to do OPERATION X COMPONENT.  If the
@@ -484,7 +494,10 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
                        :version (funcall unspecific-handler version))))))
 
 (define-modify-macro appendf (&rest args)
-  append "Append onto list")
+  append "Append onto list") ;; only to be used on short lists.
+
+(define-modify-macro orf (&rest args)
+  or "or a flag")
 
 (defun asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
@@ -649,7 +662,7 @@ actually-existing directory."
      :until (eq form eof)
      :collect form)))
 
-#-windows
+#-(and (or win32 windows mswindows mingw32) (not cygwin))
 (progn
 #+clisp (defun get-uid () (posix:uid))
 #+sbcl (defun get-uid () (sb-unix:unix-getuid))
@@ -778,7 +791,7 @@ actually-existing directory."
    (version :accessor component-version :initarg :version)
    (in-order-to :initform nil :initarg :in-order-to
                 :accessor component-in-order-to)
-   ;; XXX crap name
+   ;; XXX crap name, but it's an official API name!
    (do-first :initform nil :initarg :do-first
              :accessor component-do-first)
    ;; methods defined using the "inline" style inside a defsystem form:
@@ -834,15 +847,38 @@ actually-existing directory."
     (ignore-errors
       (prin1 (component-name c) stream))))
 
+(defvar *default-component-class* 'cl-source-file)
+
+(defun compute-module-components-by-name (module)
+  (let ((hash (module-components-by-name module)))
+    (clrhash hash)
+    (loop :for c :in (module-components module)
+      :for name = (component-name c)
+      :for previous = (gethash name (module-components-by-name module))
+      :do
+      (when previous
+        (error 'duplicate-names :name name))
+      :do (setf (gethash name (module-components-by-name module)) c))
+    hash))
+
 (defclass module (component)
-  ((components :initform nil :accessor module-components :initarg :components)
-   ;; what to do if we can't satisfy a dependency of one of this module's
-   ;; components.  This allows a limited form of conditional processing
-   (if-component-dep-fails :initform :fail
-                           :accessor module-if-component-dep-fails
-                           :initarg :if-component-dep-fails)
-   (default-component-class :accessor module-default-component-class
-     :initform 'cl-source-file :initarg :default-component-class)))
+  ((components
+    :initform nil
+    :initarg :components
+    :accessor module-components)
+   (components-by-name
+    :initform (make-hash-table :test 'equal)
+    :accessor module-components-by-name)
+   ;; What to do if we can't satisfy a dependency of one of this module's
+   ;; components.  This allows a limited form of conditional processing.
+   (if-component-dep-fails
+    :initform :fail
+    :initarg :if-component-dep-fails
+    :accessor module-if-component-dep-fails)
+   (default-component-class
+    :initform *default-component-class*
+    :initarg :default-component-class
+    :accessor module-default-component-class)))
 
 (defun component-parent-pathname (component)
   ;; No default anymore (in particular, no *default-pathname-defaults*).
@@ -984,21 +1020,9 @@ Going forward, we recommend new users should be using the source-registry.
              (let ((defaults (eval dir)))
                (when defaults
                  (cond ((directory-pathname-p defaults)
-                        (let ((file (and defaults
-                                         (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd" :case :local)))
-                               #+(and (or win32 windows) (not :clisp))
-                               (shortcut (make-pathname
-                                          :defaults defaults :version :newest
-                                          :name name :type "asd.lnk" :case :local)))
-                          (if (and file (probe-file file))
-                              (return file))
-                          #+(and (or win32 windows) (not :clisp))
-                          (when (probe-file shortcut)
-                            (let ((target (parse-windows-shortcut shortcut)))
-                              (when target
-                                (return (pathname target)))))))
+                        (let ((file (probe-asd name defaults)))
+                          (when file
+                            (return file))))
                        (t
                         (restart-case
                             (let* ((*print-circle* nil)
@@ -1043,10 +1067,11 @@ to `~a` which is not a directory.~@:>"
            ;; that's the case, well, that's not good, but as long as
            ;; the operation is otherwise considered to be done we
            ;; could continue and survive.
-  (or (and pathname (file-write-date pathname))
+  (or (and pathname (probe-file pathname) (file-write-date pathname))
       (progn
-        (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
-              pathname)
+        (when pathname
+          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+                pathname))
         0)))
 
 (defun find-system (name &optional (error-p t))
@@ -1090,8 +1115,7 @@ to `~a` which is not a directory.~@:>"
 
 (defmethod find-component ((module module) name &optional version)
   (if (slot-boundp module 'components)
-      (let ((m (find name (module-components module)
-                     :test #'equal :key #'component-name)))
+      (let ((m (gethash name (module-components-by-name module))))
         (if (and m (version-satisfies m version)) m))))
 
 
@@ -1166,13 +1190,18 @@ to `~a` which is not a directory.~@:>"
 
 (defclass operation ()
   (
-   ;; what is the TYPE of this slot?  seems like it should be boolean,
-   ;; but TRAVERSE checks to see if it's a list of component names...
-   ;; [2010/02/07:rpg]
+   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
+   ;; T to force the inside of existing system,
+   ;;   but not recurse to other systems we depend on.
+   ;; :ALL (or any other atom) to force all systems
+   ;;   including other systems we depend on.
+   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
+   ;;   to force systems named in a given list
+   ;;   (but this feature never worked before ASDF 1.700 and is cerror'ed out.)
    (forced :initform nil :initarg :force :accessor operation-forced)
    (original-initargs :initform nil :initarg :original-initargs
                       :accessor operation-original-initargs)
-   (visited-nodes :initform nil :accessor operation-visited-nodes)
+   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
    (visiting-nodes :initform nil :accessor operation-visiting-nodes)
    (parent :initform nil :initarg :parent :accessor operation-parent)))
 
@@ -1222,13 +1251,13 @@ class specifier, not an operation."
 
 (defmethod visit-component ((o operation) (c component) data)
   (unless (component-visited-p o c)
-    (push (cons (node-for o c) data)
-          (operation-visited-nodes (operation-ancestor o)))))
+    (setf (gethash (node-for o c)
+                   (operation-visited-nodes (operation-ancestor o)))
+          (cons t data))))
 
 (defmethod component-visited-p ((o operation) (c component))
-  (assoc (node-for o c)
-         (operation-visited-nodes (operation-ancestor o))
-         :test 'equal))
+  (gethash (node-for o c)
+           (operation-visited-nodes (operation-ancestor o))))
 
 (defmethod (setf visiting-component) (new-value operation component)
   ;; MCL complains about unused lexical variables
@@ -1241,7 +1270,7 @@ class specifier, not an operation."
     (if new-value
         (pushnew node (operation-visiting-nodes a) :test 'equal)
         (setf (operation-visiting-nodes a)
-              (remove node  (operation-visiting-nodes a) :test 'equal))))
+              (remove node (operation-visiting-nodes a) :test 'equal))))
   new-value)
 
 (defmethod component-visiting-p ((o operation) (c component))
@@ -1323,183 +1352,199 @@ class specifier, not an operation."
           (>= (earliest-out) (latest-in))))))))
 
 
-;;; So you look at this code and think "why isn't it a bunch of
-;;; methods".  And the answer is, because standard method combination
-;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes.
+
+;;; For 1.700 I've done my best to refactor TRAVERSE
+;;; by splitting it up in a bunch of functions,
+;;; so as to improve the collection and use-detection algorithm. --fare
+;;; The protocol is as follows: we pass around operation, dependency,
+;;; bunch of other stuff, and a force argument. Return a force flag.
+;;; The returned flag is T if anything has changed that requires a rebuild.
+;;; The force argument is a list of components that will require a rebuild
+;;; if the flag is T, at which point whoever returns the flag has to
+;;; mark them all as forced, and whoever recurses again can use a NIL list
+;;; as a further argument.
 
 (defvar *forcing* nil
   "This dynamically-bound variable is used to force operations in
 recursive calls to traverse.")
 
-(defmethod traverse ((operation operation) (c component))
-  (let ((forced nil))                   ;return value -- everyone side-effects onto this
-    (labels ((%do-one-dep (required-op required-c required-v)
-               ;; returns a partial plan that results from performing required-op
-               ;; on required-c, possibly with a required-vERSION
-               (let* ((dep-c (or (find-component
-                                  (component-parent c)
-                                  ;; XXX tacky.  really we should build the
-                                  ;; in-order-to slot with canonicalized
-                                  ;; names instead of coercing this late
-                                  (coerce-name required-c) required-v)
-                                 (if required-v
-                                     (error 'missing-dependency-of-version
-                                            :required-by c
-                                            :version required-v
-                                            :requires required-c)
-                                     (error 'missing-dependency
-                                            :required-by c
-                                            :requires required-c))))
-                      (op (make-sub-operation c operation dep-c required-op)))
-                 (traverse op dep-c)))
-             (do-one-dep (required-op required-c required-v)
-               ;; this function is a thin, error-handling wrapper around
-               ;; %do-one-dep.  Returns a partial plan per that function.
-               (loop
-                 (restart-case
-                     (return (%do-one-dep required-op required-c required-v))
-                   (retry ()
-                     :report (lambda (s)
-                               (format s "~@<Retry loading component ~S.~@:>"
-                                       required-c))
-                     :test
-                     (lambda (c)
-#|
-                        (print (list :c1 c (typep c 'missing-dependency)))
-                        (when (typep c 'missing-dependency)
-                          (print (list :c2 (missing-requires c) required-c
-                                       (equalp (missing-requires c)
-                                               required-c))))
-|#
-                       (or (null c)
-                           (and (typep c 'missing-dependency)
-                                (equalp (missing-requires c)
-                                        required-c))))))))
-             (do-dep (op dep)
-               ;; type of arguments uncertain:  op seems to at least potentially be a
-               ;; symbol, rather than an operation
-               ;; dep is either a list of component names (?) or (we hope) a single
-               ;; component name.
-               ;; handle a single dependency, returns nothing of interest --- side-
-               ;; effects onto the FORCED variable, which is scoped over TRAVERSE
-               (cond ((eq op 'feature)
-                      (or (member (car dep) *features*)
-                          (error 'missing-dependency
-                                 :required-by c
-                                 :requires (car dep))))
-                     (t
-                      (dolist (d dep)
-                        ;; structured dependencies --- this parses keywords
-                        ;; the keywords could be broken out and cleanly (extensibly)
-                        ;; processed by EQL methods, but for the pervasive side-effecting
-                        ;; onto FORCED
-                        (cond ((consp d)
-                               (cond ((string-equal
-                                       (symbol-name (first d))
-                                       "VERSION")
-                                      ;; https://bugs.launchpad.net/asdf/+bug/527788
-                                      (appendf
-                                       forced
-                                       (do-one-dep op (second d) (third d))))
-                                     ;; this particular subform is not documented, indeed
-                                     ;; clashes with the documentation, since it assumes a
-                                     ;; third component.
-                                     ;; See https://bugs.launchpad.net/asdf/+bug/518467
-                                     ((and (string-equal
-                                            (symbol-name (first d))
-                                            "FEATURE")
-                                           (find (second d) *features*
-                                                 :test 'string-equal))
-                                      (appendf
-                                       forced
-                                       (do-one-dep op (third d) nil)))
-                                     (t
-                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
-                              (t
-                               (appendf forced (do-one-dep op d nil)))))))))
+(defgeneric do-traverse (operation component collect))
+
+(defun %do-one-dep (operation c collect required-op required-c required-v)
+  ;; collects a partial plan that results from performing required-op
+  ;; on required-c, possibly with a required-vERSION
+  (let* ((dep-c (or (find-component
+                     (component-parent c)
+                     ;; XXX tacky.  really we should build the
+                     ;; in-order-to slot with canonicalized
+                     ;; names instead of coercing this late
+                     (coerce-name required-c) required-v)
+                    (if required-v
+                        (error 'missing-dependency-of-version
+                               :required-by c
+                               :version required-v
+                               :requires required-c)
+                        (error 'missing-dependency
+                               :required-by c
+                               :requires required-c))))
+         (op (make-sub-operation c operation dep-c required-op)))
+    (do-traverse op dep-c collect)))
+
+(defun do-one-dep (operation c collect required-op required-c required-v)
+  ;; this function is a thin, error-handling wrapper around
+  ;; %do-one-dep.  Returns a partial plan per that function.
+  (loop
+    (restart-case
+        (return (%do-one-dep operation c collect
+                             required-op required-c required-v))
+      (retry ()
+        :report (lambda (s)
+                  (format s "~@<Retry loading component ~S.~@:>"
+                          required-c))
+        :test
+        (lambda (c)
+          #|
+          (print (list :c1 c (typep c 'missing-dependency)))
+          (when (typep c 'missing-dependency)
+          (print (list :c2 (missing-requires c) required-c
+          (equalp (missing-requires c)
+          required-c))))
+          |#
+          (or (null c)
+              (and (typep c 'missing-dependency)
+                   (equalp (missing-requires c)
+                           required-c))))))))
+
+(defun do-dep (operation c collect op dep)
+  ;; type of arguments uncertain:
+  ;; op seems to at least potentially be a symbol, rather than an operation
+  ;; dep is a list of component names
+  (cond ((eq op 'feature)
+         (if (member (car dep) *features*)
+             nil
+             (error 'missing-dependency
+                    :required-by c
+                    :requires (car dep))))
+        (t
+         (let ((flag nil))
+           (flet ((dep (op comp ver)
+                    (when (do-one-dep operation c collect
+                                      op comp ver)
+                      (setf flag t))))
+             (dolist (d dep)
+               (if (atom d)
+                   (dep op d nil)
+                   ;; structured dependencies --- this parses keywords
+                   ;; the keywords could be broken out and cleanly (extensibly)
+                   ;; processed by EQL methods
+                   (cond ((eq :version (first d))
+                          ;; https://bugs.launchpad.net/asdf/+bug/527788
+                          (dep op (second d) (third d)))
+                         ;; This particular subform is not documented and
+                         ;; has always been broken in the past.
+                         ;; Therefore no one uses it, and I'm cerroring it out,
+                         ;; after fixing it
+                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
+                         ((eq :feature (first d))
+                          (cerror "Continue nonetheless."
+                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
+                          (when (find (second d) *features* :test 'string-equal)
+                            (dep op (third d) nil)))
+                         (t
+                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
+           flag))))
+
+(defmethod do-traverse ((operation operation) (c component) collect)
+  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
+    (labels
+        ((update-flag (x)
+           (when x
+             (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?
       (aif (component-visited-p operation c)
-           (return-from traverse
-             (if (cdr it) (list (cons 'pruned-op c)) nil)))
+           (progn
+             (update-flag (cdr it))
+             (return-from do-traverse flag)))
       ;; dependencies
-      (if (component-visiting-p operation c)
-          (error 'circular-dependency :components (list c)))
+      (when (component-visiting-p operation c)
+        (error 'circular-dependency :components (list c)))
       (setf (visiting-component operation c) t)
       (unwind-protect
-          (progn
-            ;; first we check and do all the dependencies for the
-            ;; module.  Operations planned in this loop will show up
-            ;; in the contents of the FORCED variable, and are consumed
-            ;; downstream (watch out for the shadowing FORCED variable
-            ;; around the DOLIST below!)
-            (let ((*forcing* nil))
-              ;; upstream dependencies are never forced to happen just because
-              ;; the things that depend on them are....
-              (loop :for (required-op . deps) :in
-                                              (component-depends-on operation c)
-                    :do (do-dep required-op deps)))
-            ;; constituent bits
-            (let ((module-ops
-                   (when (typep c 'module)
-                     (let ((at-least-one nil)
-                           (forced nil)
-                           ;; this is set based on the results of the
-                           ;; dependencies and whether we are in the
-                           ;; context of a *forcing* call...
-                           (must-operate (or *forcing*
-                                             ;; inter-system dependencies do NOT trigger
-                                             ;; building components
-                                             (and
-                                              (not (typep c 'system))
-                                              forced)))
-                           (error nil))
-                       (dolist (kid (module-components c))
-                           (handler-case
-                               (let ((*forcing* must-operate))
-                                 (appendf forced (traverse operation kid)))
-                             (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))
-                       forced))))
-              ;; now the thing itself
-              ;; the test here is a bit oddly written.  FORCED here doesn't
-              ;; mean that this operation is forced on this component, but that
-              ;; something upstream of this component has been forced.
-              (when (or forced module-ops
-                        *forcing*
-                        (not (operation-done-p operation c))
-                        (let ((f (operation-forced
-                                  (operation-ancestor operation))))
-                          ;; does anyone fully understand the following condition?
-                          ;; if so, please add a comment to explain it...
-                          (and f (or (not (consp f))
-                                     (member (component-name
-                                              (operation-ancestor operation))
-                                             (mapcar #'coerce-name f)
-                                             ;; this was string=, but for the benefit
-                                             ;; of mlisp, we use string-equal for this
-                                             ;; purpose.
-                                             :test #'string-equal)))))
-                (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 required-op deps)))
-                (setf forced (append (delete 'pruned-op forced :key #'car)
-                                     (delete 'pruned-op module-ops :key #'car)
-                                     (list (cons operation c)))))))
-        (setf (visiting-component operation c) nil))
-      (visit-component operation c (and forced t))
-      forced)))
+           (progn
+             ;; first we check and do all the dependencies for the module.
+             ;; Operations planned in this loop will show up
+             ;; in the results, and are consumed below.
+             (let ((*forcing* nil))
+               ;; upstream dependencies are never forced to happen just because
+               ;; the things that depend on them are....
+               (loop
+                 :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)))
+      (visit-component operation c flag)
+      flag))
 
+(defmethod traverse ((operation operation) (c component))
+  ;; cerror'ing a feature that seems to have NEVER EVER worked,
+  ;; ever since danb created it in his 2003-03-16 commit e0d02781
+  (when (consp (operation-forced operation))
+    (cerror "Continue nonetheless."
+            "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)))
 
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
@@ -1870,7 +1915,7 @@ Returns the new tree (which probably shares structure with the old one)"
     new-tree))
 
 
-(defvar *serial-depends-on*)
+(defvar *serial-depends-on* nil)
 
 (defun sysdef-error-component (msg type name value)
   (sysdef-error (concatenate 'string msg
@@ -1924,7 +1969,6 @@ Returns the new tree (which probably shares structure with the old one)"
   (%define-component-inline-methods component rest))
 
 (defun parse-component-form (parent options)
-
   (destructuring-bind
         (type name &rest rest &key
               ;; the following list of keywords is reproduced below in the
@@ -1956,10 +2000,9 @@ Returns the new tree (which probably shares structure with the old one)"
             (or (find-component parent name)
                 (make-instance (class-for-type parent type)))))
       (when weakly-depends-on
-        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
-      (when (boundp '*serial-depends-on*)
-        (setf depends-on
-              (concatenate 'list *serial-depends-on* depends-on)))
+        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
+      (when *serial-depends-on*
+        (push *serial-depends-on* depends-on))
       (apply #'reinitialize-instance ret
              :name (coerce-name name)
              :pathname pathname
@@ -1973,21 +2016,13 @@ Returns the new tree (which probably shares structure with the old one)"
                        (module-default-component-class parent))))
         (let ((*serial-depends-on* nil))
           (setf (module-components ret)
-                (loop :for c-form :in components
+                (loop
+                  :for c-form :in components
                   :for c = (parse-component-form ret c-form)
+                  :for name = (component-name c)
                   :collect c
-                  :if serial
-                  :do (push (component-name c) *serial-depends-on*))))
-
-        ;; check for duplicate names
-        (let ((name-hash (make-hash-table :test #'equal)))
-          (loop :for c in (module-components ret) :do
-            (if (gethash (component-name c)
-                         name-hash)
-                (error 'duplicate-names :name (component-name c))
-                (setf (gethash (component-name c)
-                               name-hash)
-                      t)))))
+                  :when serial :do (setf *serial-depends-on* name))))
+        (compute-module-components-by-name ret))
 
       (setf (component-in-order-to ret)
             (union-of-dependencies
@@ -2221,7 +2256,7 @@ located."
        ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
            :for dir :in (split-string dirs :separator ":")
            :collect (try dir "common-lisp/"))
-       #+windows
+       #+(and (or win32 windows mswindows mingw32) (not cygwin))
         ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
             ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
            #+(not cygwin)
@@ -2232,13 +2267,11 @@ located."
   (remove-if
    #'null
    (append
-    #+windows
+    #+(and (or win32 windows mswindows mingw32) (not cygwin))
     (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-      `(
-       ,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
+      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-           #+(not cygwin)
-           ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
+        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
     (list #p"/etc/"))))
 (defun in-first-directory (dirs x)
   (loop :for dir :in dirs
@@ -2305,7 +2338,7 @@ and the order is by decreasing length of namestring of the source pathname.")
    #+(and windows lispworks)
    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
      (and h `(,h "common-lisp" "cache")))
-   #+(and windows (not cygwin))
+   #+(and (or win32 windows mswindows mingw32) (not cygwin))
    ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Cache
    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
@@ -2315,7 +2348,7 @@ and the order is by decreasing length of namestring of the source pathname.")
    #+(and windows lispworks)
    (let ((h (sys:get-folder-path :common-appdata))) ;; no :common-caches in Windows???
      (and h `(,h "common-lisp" "cache")))
-   #+windows
+   #+(and (or win32 windows mswindows mingw32) (not cygwin))
    (let ((h (or (getenv "USERPROFILE") (user-homedir))))
      (and h `(,h "Local Settings" "Temporary Internet Files" "common-lisp")))
    #+(or unix cygwin)
@@ -2854,29 +2887,33 @@ with a different configuration, so the configuration would be re-read then."
   (setf *source-registry* '())
   (values))
 
+(defun probe-asd (name defaults)
+  (block nil
+    (when (directory-pathname-p defaults)
+      (let ((file
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name name
+              :type "asd")))
+        (when (probe-file file)
+          (return file)))
+      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
+      (let ((shortcut
+             (make-pathname
+              :defaults defaults :version :newest :case :local
+              :name (concatenate 'string name ".asd")
+              :type "lnk")))
+        (when (probe-file shortcut)
+          (let ((target (parse-windows-shortcut shortcut)))
+            (when target
+              (return (pathname target)))))))))
+
 (defun sysdef-source-registry-search (system)
   (ensure-source-registry)
-  (let ((name (coerce-name system)))
-    (block nil
-      (dolist (dir (source-registry))
-        (let ((defaults (eval dir)))
-          (when defaults
-            (cond ((directory-pathname-p defaults)
-                   (let ((file (and defaults
-                                    (make-pathname
-                                     :defaults defaults :version :newest
-                                     :name name :type "asd" :case :local)))
-                         #+(and (or win32 windows) (not :clisp))
-                         (shortcut (make-pathname
-                                    :defaults defaults :version :newest
-                                    :name name :type "asd.lnk" :case :local)))
-                     (when (and file (probe-file file))
-                       (return file))
-                     #+(and (or win32 windows) (not :clisp))
-                     (when (probe-file shortcut)
-                       (let ((target (parse-windows-shortcut shortcut)))
-                         (when target
-                           (return (pathname target))))))))))))))
+  (loop :with name = (coerce-name system)
+    :for defaults :in (source-registry)
+    :for file = (probe-asd name defaults)
+    :when file :return file))
 
 (defun validate-source-registry-directive (directive)
   (unless
@@ -2981,7 +3018,7 @@ with a different configuration, so the configuration would be re-read then."
           (datadirs
            (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
           (dirs (cons datahome (split-string datadirs :separator ":"))))
-         #+(and windows (not cygwin))
+         #+(and (or win32 windows mswindows mingw32) (not cygwin))
          ((datahome
            #+lispworks (sys:get-folder-path :common-appdata)
            #-lispworks (try (or (getenv "USERPROFILE") (user-homedir))
@@ -2991,7 +3028,7 @@ with a different configuration, so the configuration would be re-read then."
            #-lispworks (try (getenv "ALLUSERSPROFILE")
                             "Application Data"))
           (dirs (list datahome datadir)))
-         #+(and (not unix) (not windows) (not cygwin))
+         #-(or unix win32 windows mswindows mingw32 cygwin)
          ((dirs ()))
          (loop :for dir :in dirs
            :collect `(:directory ,(try dir "common-lisp/systems/"))
diff --git a/doc/.htaccess b/doc/.htaccess
new file mode 100644
index 00000000..b20598c3
--- /dev/null
+++ b/doc/.htaccess
@@ -0,0 +1 @@
+Redirect /project/asdf/manual.html http://common-lisp.net/project/asdf/asdf.html
diff --git a/doc/Makefile b/doc/Makefile
index 262cccfe..d6d7b1c0 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -1,7 +1,7 @@
 user=frideau
 website:=${user}@common-lisp.net:/project/asdf/public_html/
 output = asdf.html asdf asdf.pdf asdf.info
-webfiles = index.html manual.html style.css cclan.png lisp-logo120x80.png favicon.ico ${output}
+webfiles = index.html .htaccess style.css cclan.png lisp-logo120x80.png favicon.ico ${output}
 intermediate = asdf.cps asdf.log asdf.vr asdf.aux asdf.fn asdf.toc asdf.vrs \
 	asdf.cp asdf.fns asdf.ky asdf.pg asdf.tp
 
@@ -19,7 +19,7 @@ asdf.info: asdf.texinfo
 asdf.pdf: asdf.texinfo
 	texi2pdf asdf.texinfo
 
-website:
+website: all
 	rsync -av ${webfiles} ${website}
 
 .PHONY: clean veryclean manual-html
diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo
index f66dd5e4..119eaba6 100644
--- a/doc/asdf.texinfo
+++ b/doc/asdf.texinfo
@@ -32,6 +32,9 @@
 This manual describes ASDF, a system definition facility
 for Common Lisp programs and libraries.
 
+You can find the latest version of this manual at
+@url{http://common-lisp.net/project/asdf/asdf.html}.
+
 ASDF Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
 
 This manual Copyright @copyright{} 2001-2010 Daniel Barlow and contributors.
diff --git a/doc/manual.html b/doc/manual.html
deleted file mode 100644
index 74e6d6cb..00000000
--- a/doc/manual.html
+++ /dev/null
@@ -1,10 +0,0 @@
-<html><head>
-<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
-<meta http-equiv="Refresh" content="0;url=asdf.html">
-<title>This page has moved</title>
-</head><body>
-This page has moved.
-<a href="asdf.html">Click here</a>
-to go to its new address
-<p>
-</body></html>
diff --git a/test/test1.script b/test/test1.script
index 3768e0ee..fe6955f8 100644
--- a/test/test1.script
+++ b/test/test1.script
@@ -22,6 +22,7 @@
    ;; recompiled
    (sleep 1) ; mtime has 1-second granularity, so pause here for fast machines
 
+   (trace asdf::operation-done-p asdf::traverse)
    (asdf::run-shell-command "rm -f ~A" (namestring file2))
    (asdf:operate 'asdf:load-op 'test1)
    (assert (= file1-date (file-write-date file1)))
@@ -36,4 +37,4 @@
      (sleep 1)
      (asdf::run-shell-command "touch file1.lisp")
      (asdf:operate 'asdf:load-op 'test1)
-     (assert (>  (file-write-date file2) before)))))
+     (assert (> (file-write-date file2) before)))))
diff --git a/test/test2b1.asd b/test/test2b1.asd
index bc94d5d9..f91f21e3 100644
--- a/test/test2b1.asd
+++ b/test/test2b1.asd
@@ -3,4 +3,4 @@
     :version "1.0"
     :components ((:file "file2" :in-order-to ((compile-op (load-op "file1"))))
                  (:file "file1"))
-    :in-order-to ((load-op (load-op (version test2a "1.1")))))
+    :in-order-to ((load-op (load-op (:version test2a "1.1")))))
diff --git a/test/test2b2.asd b/test/test2b2.asd
index 6b294c30..4c4cfb91 100644
--- a/test/test2b2.asd
+++ b/test/test2b2.asd
@@ -3,6 +3,6 @@
     :version "1.0"
     :components ((:file "file2" :in-order-to ((compile-op (load-op "file1"))))
                  (:file "file1"))
-    :in-order-to ((load-op (load-op (version test2a "1.2")))))
+    :in-order-to ((load-op (load-op (:version test2a "1.2")))))
 
 
diff --git a/test/test2b3.asd b/test/test2b3.asd
index 9bc997fd..3ec8ae6b 100644
--- a/test/test2b3.asd
+++ b/test/test2b3.asd
@@ -4,5 +4,3 @@
     :components ((:file "file2" :in-order-to ((compile-op (load-op "file1"))))
                  (:file "file1"))
     :depends-on (bet-you-cant-find-this))
-
-
-- 
GitLab