From 2387083f8a27a11ef639ee5d9945e89b7c2a7c37 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 25 Jan 2010 11:32:40 -0500
Subject: [PATCH] Make tests work with CL_SOURCE_REGISTRY Fix
 CL_SOURCE_REGISTRY support (oops). Refactor uses of (loop ...)

---
 asdf.lisp         | 279 ++++++++++++++++++++++------------------------
 test/run-tests.sh |   1 +
 2 files changed, 136 insertions(+), 144 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index 5a737190..b5dbd771 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -23,7 +23,7 @@
 ;;;  http://www.opensource.org/licenses/mit-license.html on or about
 ;;;  Monday; July 13, 2009)
 ;;;
-;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;; a copy of this software and associated documentation files (the
@@ -395,19 +395,15 @@ and NIL NAME and TYPE components"
          (values relative (butlast components) last-comp))))))
 
 (defun remove-keys (key-names args)
-  (loop for (name val) on args by #'cddr
-        unless (member (symbol-name name) key-names
-                       :key #'symbol-name :test 'equal)
-        append (list name val)))
-
-(defun remove-keyword (key arglist)
-  (labels ((aux (key arglist)
-             (cond ((null arglist) nil)
-                   ((eq key (car arglist)) (cddr arglist))
-                   (t (cons (car arglist) (cons (cadr arglist)
-                                                (remove-keyword
-                                                 key (cddr arglist))))))))
-    (aux key arglist)))
+  (loop :for (name val) :on args :by #'cddr
+    :unless (member (symbol-name name) key-names
+                    :key #'symbol-name :test 'equal)
+    :append (list name val)))
+
+(defun remove-keyword (key args)
+  (loop :for (k v) :on args :by #'cddr
+    :unless (eq k key)
+    :append (list k v)))
 
 (defun resolve-symlinks (path)
   #-allegro (truename path)
@@ -1099,26 +1095,26 @@ to `~a` which is not a directory.~@:>"
       (setf (visiting-component operation c) t)
       (unwind-protect
            (progn
-             (loop for (required-op . deps) in
-                  (component-depends-on operation c)
-                  do (do-dep required-op deps))
+             (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)
                             (error nil))
-                        (loop for kid in (module-components c)
-                           do (handler-case
-                                  (appendf forced (traverse operation kid ))
-                                (missing-dependency (condition)
-                                  (if (eq (module-if-component-dep-fails c)
-                                          :fail)
-                                      (error condition))
-                                  (setf error condition))
-                                (:no-error (c)
-                                  (declare (ignore c))
-                                  (setf at-least-one t))))
+                        (dolist (kid (module-components c))
+                          (handler-case
+                              (appendf forced (traverse operation kid ))
+                            (missing-dependency (condition)
+                              (if (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))
@@ -1136,8 +1132,8 @@ to `~a` which is not a directory.~@:>"
                                               :test #'string=)))))
                  (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)))
+                   (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)))))))
@@ -1228,8 +1224,8 @@ to `~a` which is not a directory.~@:>"
 
 (defmethod perform around ((o load-op) (c cl-source-file))
   (let ((state :initial))
-    (loop until (or (eq state :success)
-                    (eq state :failure)) do
+    (loop :until (or (eq state :success)
+                     (eq state :failure)) :do
          (case state
            (:recompiled
             (setf state :failure)
@@ -1248,8 +1244,8 @@ to `~a` which is not a directory.~@:>"
 
 (defmethod perform around ((o compile-op) (c cl-source-file))
   (let ((state :initial))
-    (loop until (or (eq state :success)
-                    (eq state :failure)) do
+    (loop :until (or (eq state :success)
+                     (eq state :failure)) :do
          (case state
            (:recompiled
             (setf state :failure)
@@ -1346,26 +1342,26 @@ to `~a` which is not a directory.~@:>"
       (error 'missing-component-of-version :requires system :version version))
     (let ((steps (traverse op system)))
       (with-compilation-unit ()
-        (loop for (op . component) in steps do
-                 (loop
-                   (restart-case
-                       (progn (perform op component)
-                              (return))
-                     (retry ()
-                       :report
-                       (lambda (s)
-                         (format s "~@<Retry performing ~S on ~S.~@:>"
-                                 op component)))
-                     (accept ()
-                       :report
-                       (lambda (s)
-                         (format s "~@<Continue, treating ~S on ~S as ~
+        (loop :for (op . component) :in steps :do
+          (loop
+            (restart-case
+                (progn (perform op component)
+                       (return))
+              (retry ()
+                :report
+                (lambda (s)
+                  (format s "~@<Retry performing ~S on ~S.~@:>"
+                          op component)))
+              (accept ()
+                :report
+                (lambda (s)
+                  (format s "~@<Continue, treating ~S on ~S as ~
                                    having been successful.~@:>"
-                                 op component))
-                       (setf (gethash (type-of op)
-                                      (component-operation-times component))
-                             (get-universal-time))
-                       (return)))))))
+                          op component))
+                (setf (gethash (type-of op)
+                               (component-operation-times component))
+                      (get-universal-time))
+                (return)))))))
     op))
 
 (defun oos (operation-class system &rest args &key force (verbose t) version
@@ -1531,30 +1527,30 @@ Returns the new tree (which probably shares structure with the old one)"
                             type name in-order-to)))
 
 (defun %remove-component-inline-methods (component)
-  (loop for name in +asdf-methods+
-        do (map 'nil
-                ;; this is inefficient as most of the stored
-                ;; methods will not be for this particular gf n
-                ;; But this is hardly performance-critical
-                (lambda (m)
-                  (remove-method (symbol-function name) m))
-                (component-inline-methods component)))
+  (dolist (name +asdf-methods+)
+    (map ()
+         ;; this is inefficient as most of the stored
+         ;; methods will not be for this particular gf n
+         ;; But this is hardly performance-critical
+         (lambda (m)
+           (remove-method (symbol-function name) m))
+         (component-inline-methods component)))
   ;; clear methods, then add the new ones
   (setf (component-inline-methods component) nil))
 
 (defun %define-component-inline-methods (ret rest)
-  (loop for name in +asdf-methods+ do
-       (let ((keyword (intern (symbol-name name) :keyword)))
-         (loop for data = rest then (cddr data)
-              for key = (first data)
-              for value = (second data)
-              while data
-              when (eq key keyword) do
-              (destructuring-bind (op qual (o c) &body body) value
-              (pushnew
-                 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
-                                   ,@body))
-                 (component-inline-methods ret)))))))
+  (dolist (name +asdf-methods+)
+    (let ((keyword (intern (symbol-name name) :keyword)))
+      (loop :for data = rest :then (cddr data)
+        :for key = (first data)
+        :for value = (second data)
+        :while data
+        :when (eq key keyword) :do
+        (destructuring-bind (op qual (o c) &body body) value
+          (pushnew
+           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+                             ,@body))
+           (component-inline-methods ret)))))))
 
 (defun %refresh-component-inline-methods (component rest)
   (%remove-component-inline-methods component)
@@ -1609,23 +1605,22 @@ 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
-                      for c = (parse-component-form ret c-form)
-                      collect c
-                      if serial
-                      do (push (component-name c) *serial-depends-on*))))
+                (loop :for c-form :in components
+                  :for c = (parse-component-form ret c-form)
+                  :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)))))
+          (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)))))
 
       (setf (component-in-order-to ret)
             (union-of-dependencies
@@ -1860,8 +1855,8 @@ operating system, and hardware architecture."
                               (let ((feature (find subf *features*)))
                                 (when feature (return-from fp (first thing))))))))
                        (first-of (features)
-                         (loop for f in features
-                            when (fp f) return it))
+                         (loop :for f :in features
+                           :when (fp f) :return :it))
                        (maybe-warn (value fstring &rest args)
                          (cond (value)
                                (t (apply #'warn fstring args)
@@ -1898,12 +1893,11 @@ follow that.  For example, if SBCL is installed under a symlink, and
 SBCL_HOME is set through that symlink, the default rule above
 preventing SBCL contribs from being mapped elsewhere will not be
 applied by the plain `*source-to-target-mappings*`."
-  (loop for mapping in asdf:*source-to-target-mappings*
-        for (source target) = mapping
-        for true-source = (and source (resolve-symlinks source))
-        if (equal source true-source)
-          collect mapping
-        else append (list mapping (list true-source target))))
+  (loop :for mapping :in asdf:*source-to-target-mappings*
+    :for (source target) = mapping
+    :for true-source = (and source (resolve-symlinks source))
+    :if (equal source true-source) :collect mapping
+    :else :append (list mapping (list true-source target))))
 
 (defmethod output-files-for-system-and-operation
            ((system system) operation component source possible-paths)
@@ -1914,43 +1908,42 @@ applied by the plain `*source-to-target-mappings*`."
 (defmethod output-files-using-mappings (source possible-paths path-mappings)
   (mapcar
    (lambda (path)
-     (loop for (from to) in path-mappings
-        when (pathname-prefix-p from source)
-        do (return
-             (if to
-                 (merge-pathnames
-                  (make-pathname :type (pathname-type path))
-                  (merge-pathnames (enough-namestring source from)
-                                   to))
-                 path))
-
-        finally
-          (return
-            ;; Instead of just returning the path when we
-            ;; don't find a mapping, we stick stuff into
-            ;; the appropriate binary directory based on
-            ;; the implementation
-            (if *centralize-lisp-binaries*
-                (merge-pathnames
-                 (make-pathname
-                  :type (pathname-type path)
-                  :directory `(:relative
-                               ,@(cond ((eq *include-per-user-information* t)
-                                        (cdr (pathname-directory
-                                              (user-homedir-pathname))))
-                                       ((not (null *include-per-user-information*))
-                                        (list *include-per-user-information*)))
-                               ,@(implementation-specific-directory-name)
-                               ,@(rest (pathname-directory path)))
-                  :defaults path)
-                 *default-toplevel-directory*)
-                (make-pathname
-                 :type (pathname-type path)
-                 :directory (append
-                             (pathname-directory path)
-                             (implementation-specific-directory-name))
-                 :defaults path)))))
-          possible-paths))
+     (loop :for (from to) :in path-mappings
+       :when (pathname-prefix-p from source)
+       :return
+       (if to
+           (merge-pathnames
+            (make-pathname :type (pathname-type path))
+            (merge-pathnames (enough-namestring source from)
+                             to))
+           path)
+       :finally
+       (return
+         ;; Instead of just returning the path when we
+         ;; don't find a mapping, we stick stuff into
+         ;; the appropriate binary directory based on
+         ;; the implementation
+         (if *centralize-lisp-binaries*
+             (merge-pathnames
+              (make-pathname
+               :type (pathname-type path)
+               :directory `(:relative
+                            ,@(cond ((eq *include-per-user-information* t)
+                                     (cdr (pathname-directory
+                                           (user-homedir-pathname))))
+                                    ((not (null *include-per-user-information*))
+                                     (list *include-per-user-information*)))
+                            ,@(implementation-specific-directory-name)
+                            ,@(rest (pathname-directory path)))
+               :defaults path)
+              *default-toplevel-directory*)
+             (make-pathname
+              :type (pathname-type path)
+              :directory (append
+                          (pathname-directory path)
+                          (implementation-specific-directory-name))
+              :defaults path)))))
+   possible-paths))
 
 (defmethod output-files
     :around ((operation compile-op) (component source-file))
@@ -1976,18 +1969,14 @@ applied by the plain `*source-to-target-mappings*`."
 
 (defun read-null-terminated-string (s)
   (with-output-to-string (out)
-    (loop
-        for code = (read-byte s)
-        until (zerop code)
-        do (write-char (code-char code) out))))
+    (loop :for code = (read-byte s)
+      :until (zerop code)
+      :do (write-char (code-char code) out))))
 
 (defun read-little-endian (s &optional (bytes 4))
-  (let ((result 0))
-    (loop
-        for i from 0 below bytes
-        do
-          (setf result (logior result (ash (read-byte s) (* 8 i)))))
-    result))
+  (loop
+    :for i :from 0 :below bytes
+    :sum (ash (read-byte s) (* 8 i))))
 
 (defun parse-file-location-info (s)
   (let ((start (file-position s))
@@ -2144,7 +2133,9 @@ with a different configuration, so the configuration would be re-read then."
     (validate-source-registry-form (car forms))))
 
 (defun validate-source-registry-directory (directory)
-  (let ((files (sort (directory (merge-pathnames "*.*" directory)
+  (let ((files (sort (directory (merge-pathnames
+                                 (make-pathname :name :wild :type :wild)
+                                 directory)
                                 #+sbcl :resolve-symlinks #+sbcl nil)
                      #'string< :key #'namestring)))
     `(:source-registry
@@ -2182,7 +2173,7 @@ with a different configuration, so the configuration would be re-read then."
          (when (>= start end)
            (unless inherit
              (push '(:ignore-inherited-configuration) directives))
-           (return `(:source-registry ,(nreverse directives)))))))))
+           (return `(:source-registry ,@(nreverse directives)))))))))
 
 (defun collect-asd-subdirectories (directory &key (exclude *default-exclusions*) collect)
   (let* ((files (directory (merge-pathnames #P"**/*.asd" directory)
diff --git a/test/run-tests.sh b/test/run-tests.sh
index bff1c3ce..cb82c1ef 100755
--- a/test/run-tests.sh
+++ b/test/run-tests.sh
@@ -5,6 +5,7 @@
 # - quit with exit status 0 on getting eof
 # - quit with exit status >0 if an unhandled error occurs
 
+export CL_SOURCE_REGISTRY=$PWD
 
 if [ x"$1" = "xhelp" ]; then
     echo "$0 [lisp invocation] [scripts-regex]"
-- 
GitLab