From 3ba2b9773b36c9d3d87a8d3888f63c8de9da24f7 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@gmail.com>
Date: Sun, 23 Feb 2014 10:24:35 -0600
Subject: [PATCH] Putting introspection functions in canonical form.

SYSTEM-DEFSYSTEM-DEPENDS-ON, SYSTEM-DEPENDS-ON, and
SYSTEM-WEAKLY-DEPENDS-ON now always return s-expressions with system
names represented as downcased caps (per COERCE-NAME).
---
 parse-defsystem.lisp                     | 39 ++++++++++++++++++++++--
 test/test-cache-for-introspection.script | 24 +++++++++++++--
 2 files changed, 57 insertions(+), 6 deletions(-)

diff --git a/parse-defsystem.lisp b/parse-defsystem.lisp
index a6f3d453..1c66dae5 100644
--- a/parse-defsystem.lisp
+++ b/parse-defsystem.lisp
@@ -133,6 +133,30 @@
 
 ;;; Main parsing function
 (with-upgradability ()
+  (defun* parse-dependency-def (dd)
+    (if (listp dd)
+        (case (first dd)
+          (:feature
+           (unless (= (length dd) 3)
+             (sysdef-error "Ill-formed feature dependency: ~s" dd))
+           (let ((embedded (parse-dependency-def (third dd))))
+             `(:feature ,(second dd) ,embedded)))
+          (:require
+           (unless (= (length dd) 2)
+             (sysdef-error "Ill-formed require dependency: ~s" dd))
+           dd)
+          (:version
+           (unless (= (length dd) 3)
+             (sysdef-error "Ill-formed version dependency: ~s" dd))
+           `(:version ,(coerce-name (second dd)) ,(third dd)))
+          (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
+      (coerce-name dd)))
+
+  (defun* parse-dependency-defs (dd-list)
+    "Parse the dependency defs in DD-LIST into canonical form by translating all
+system names contained using COERCE-NAME. Return the result."
+    (mapcar 'parse-dependency-def dd-list))
+
   (defun* (parse-component-form) (parent options &key previous-serial-component)
     (destructuring-bind
         (type name &rest rest &key
@@ -172,8 +196,11 @@
         (component-pathname component) ; eagerly compute the absolute pathname
         (when (typep component 'system)
           ;; cache information for introspection
-          (setf (slot-value component 'depends-on) depends-on
-                (slot-value component 'weakly-depends-on) weakly-depends-on))
+          (setf (slot-value component 'depends-on)
+                (parse-dependency-defs depends-on)
+                (slot-value component 'weakly-depends-on)
+                ;; these must be a list of systems, cannot be features or versioned systems
+                (mapcar 'coerce-name weakly-depends-on)))
         (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
           (when (and (typep component 'system) (not bspp))
             (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
@@ -227,9 +254,15 @@
                                (make-instance 'system :name name :source-file source-file))))
              (system (reset-system (cdr registered!)
                                    :name name :source-file source-file))
-             (component-options (remove-plist-key :class options))
+             (component-options
+              (remove-plist-keys '(:defsystem-depends-on :class) options))
              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
                                            (resolve-dependency-spec nil spec))))
+        ;; cache defsystem-depends-on in canonical form
+        (when defsystem-depends-on
+          (setf component-options
+                (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on))
+                        component-options)))
         (setf (gethash name *systems-being-defined*) system)
         (load-systems* defsystem-dependencies)
         ;; We change-class AFTER we loaded the defsystem-depends-on
diff --git a/test/test-cache-for-introspection.script b/test/test-cache-for-introspection.script
index 54bcc665..058453b4 100644
--- a/test/test-cache-for-introspection.script
+++ b/test/test-cache-for-introspection.script
@@ -16,6 +16,11 @@
   :pathname #.*test-directory*
   :version "1.2")
 
+(def-test-system :versioned-system-4
+  :defsystem-depends-on ((:version test-asdf/2 "2.1"))
+  :pathname #.*test-directory*
+  :version "1.2")
+
 (def-test-system :test-concatenate-source
   :depends-on (:file3-only)
   :components
@@ -24,16 +29,29 @@
     :components ((:file "file1")
                  (:file "file4" :if-feature (:not :common-lisp))))))
 
+(def-test-system :test-structured-depends
+  :depends-on ((:version test-asdf/2 "2.1") :file3-only (:feature :foo (:require "blort")))
+  :components
+  ((:file "file2" :depends-on ("foo"))
+   (:module "foo" :pathname ""
+    :components ((:file "file1")
+                 (:file "file4" :if-feature (:not :common-lisp))))))
 
 
 (DBG "The weakly-depends-on information is properly cached")
-(assert (equal '(file3-only) (system-weakly-depends-on (find-system "test-weakly-depends-on"))))
+(assert (equal '("file3-only") (system-weakly-depends-on (find-system "test-weakly-depends-on"))))
 (assert (null (system-weakly-depends-on (find-system "test-no-weakly-depends-on"))))
 
 (DBG "The depends-on information is properly cached")
 (assert (null (system-depends-on (find-system "test-no-weakly-depends-on"))))
-(assert (equalp '(:file3-only) (system-depends-on (find-system "test-concatenate-source"))))
+(assert (equalp '("file3-only") (system-depends-on (find-system "test-concatenate-source"))))
 
 (DBG "The defsystem-depends-on information is properly cached")
 (assert (null (system-defsystem-depends-on (find-system "test-no-weakly-depends-on"))))
-(assert (equalp '((:version :test-asdf/2 "2.1")) (system-defsystem-depends-on (find-system :versioned-system-3))))
\ No newline at end of file
+(assert (equalp '((:version "test-asdf/2" "2.1")) (system-defsystem-depends-on (find-system :versioned-system-3))))
+(assert (equalp '((:version "test-asdf/2" "2.1")) (system-defsystem-depends-on (find-system :versioned-system-4))))
+
+(DBG "Test structured dependencies")
+(assert (equalp
+          '((:version "test-asdf/2" "2.1") "file3-only" (:feature :foo (:require "blort")))
+          (system-depends-on (find-system :test-structured-depends))))
-- 
GitLab