From 4a27b93af41453be1fed86c64d37ad34f54ddc0a Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sun, 15 Nov 2009 21:25:15 -0500
Subject: [PATCH] Transform some ugly macro with bad loop that warns under
 clisp into clean higher-order function. Add TODO item.

---
 INCREMENTAL-TODO |  7 ++++--
 asdf-ops.lisp    | 60 +++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 52 insertions(+), 15 deletions(-)

diff --git a/INCREMENTAL-TODO b/INCREMENTAL-TODO
index 04e607d..ed06790 100644
--- a/INCREMENTAL-TODO
+++ b/INCREMENTAL-TODO
@@ -8,5 +8,8 @@
    why things depend on each other.
 
 
-* rewrite ADG to use a fully instrumented code-walker + CL-in-CL implementation
-  so we don't have to approximate dependencies when we can trace them directly.
+* rewrite ADG to use SB-COVER,
+  so we don't have to approximate dependencies when we can trace them
+  directly.
+  More difficult would be to writ your own fully instrumented
+  code-walker and coverage CL-in-CL implementation.
diff --git a/asdf-ops.lisp b/asdf-ops.lisp
index f2b659c..ee9395b 100644
--- a/asdf-ops.lisp
+++ b/asdf-ops.lisp
@@ -172,14 +172,14 @@ to the base of the system."
                        "Component spec ~S in ~S didn't find a component."
                        compspec system)
                (apply #'reinitialize-instance component args))))
-    (loop for (system compspec . initargs) in additional-initargs
-          do (assert (member (asdf::coerce-name system) systems
-                             :key #'asdf::coerce-name
-                             :test #'equal)
-                     ()
-                     "Component translation in System ~A which is not a member of the ~
-                           systems to merge." system)
-          do (add-initargs system compspec initargs))))
+    (loop :for (system compspec . initargs) in additional-initargs :do
+      (assert (member (asdf::coerce-name system) systems
+                      :key #'asdf::coerce-name
+                      :test #'equal)
+              ()
+              "Component translation in System ~A which is not a member of the ~
+               systems to merge." system)
+      (add-initargs system compspec initargs))))
 
 (defmethod asdf:perform ((op dependency-op) (c component-file))
   (let ((tmp-file-name (format nil "~A-~A"
@@ -231,10 +231,43 @@ to the base of the system."
 
 ;;; Reading the component list back into asdf defsystems
 
+(defun %comp-file-reader (pathname system-names collector)
+  (with-open-file (f pathname :direction :input)
+    (let ((systems (read f))
+          (done-systems nil))
+      (labels ((do-1-system (system-name)
+                 (unless (position system-name done-systems
+                                   :test #'string-equal)
+                   (let ((system (assoc system-name systems
+                                              :test #'string-equal)))
+                     (funcall collector system)
+                     (push system-name done-systems)
+                     (getf (cdr system) :depends-on)))))
+        (loop :while system-names :do
+          (let ((system-name (pop system-names)))
+            (setf system-names (append system-names (do-1-system system-name)))))))))
+
+(defun read-component-file (pathname &rest system-names)
+  (let ((component-list nil))
+    (%comp-file-reader
+     pathname system-names
+     (lambda (system)
+       (setf component-list
+             (append component-list (getf (cdr system) :components)))))))
+
+(defun systems-in-configuration (pathname &rest system-names)
+  (let ((component-names nil))
+    (%comp-file-reader
+     pathname system-names
+     (lambda (system)
+       (when system
+         (push (first system) component-names))))))
+
+#|
+;; Old macro-ish version by antifuchs:
 (macrolet
     ((define-comp-file-reader (fname (1-system-var return-var)
                                      &body 1-system-body)
-         
          (let ((system-name (gensym))
                (system-names (gensym))
                (done-systems (gensym))
@@ -252,10 +285,10 @@ to the base of the system."
                                  (progn ,@1-system-body)
                                  (push ,system-name ,done-systems)
                                  (getf (cdr ,1-system-var) :depends-on)))))
-                    (loop while ,system-names
-                          for ,system-name = (pop ,system-names)
-                          do (setf ,system-names (append ,system-names
-                                                        (do-1-system ,system-name))))
+                    (loop :while ,system-names :do
+                      (let ((,system-name (pop ,system-names)))
+                        (setf ,system-names (append ,system-names
+                                                    (do-1-system ,system-name)))))
                     ,return-var)))))))
   (define-comp-file-reader read-component-file (system component-list)
     (setf component-list
@@ -263,6 +296,7 @@ to the base of the system."
   (define-comp-file-reader systems-in-configuration (system component-names)
     (when system
       (push (first system) component-names))))
+|#
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-- 
GitLab