From bae381cbf2afe6dd0253edd8b5bf33794371f48f Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Thu, 2 Feb 2017 15:08:25 -0500
Subject: [PATCH] Fix images for ASDF-dependent systems on ECL

Recent ECLs have libasdf.a instead of asdf.a.

Not all bundle-op is a basic-compile-op (e.g. concatenate-source-op).
Declaring otherwise was causing asdf/defsystem to appear as a compiled
dependency, causing incorrect double inclusion of symbols in the link
when asdf was explicitly depended on.

Make sure to include only one of uiop or asdf as the fallback support file,
and only when neither uiop nor asdf is explicitly depended on.

Improve test-program.script for ECL.

This fixes https://bugs.launchpad.net/bugs/1660547
---
 bundle.lisp              | 44 ++++++++++++++++++++++------------------
 test/script-support.lisp |  2 +-
 test/test-program.script | 40 ++++++++++++++++++++++++++++++++++--
 3 files changed, 63 insertions(+), 23 deletions(-)

diff --git a/bundle.lisp b/bundle.lisp
index 6c64647c2..8582a4868 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -21,7 +21,7 @@
 (in-package :asdf/bundle)
 
 (with-upgradability ()
-  (defclass bundle-op (basic-compile-op)
+  (defclass bundle-op (operation)
     ;; NB: use of instance-allocated slots for operations is DEPRECATED
     ;; and only supported in a temporary fashion for backward compatibility.
     ;; Supported replacement: Define slots on program-system instead.
@@ -107,7 +107,7 @@ itself."))
       `((,go ,@deps) ,@(call-next-method))))
 
   ;; Create a single fasl for the entire library
-  (defclass basic-compile-bundle-op (bundle-op)
+  (defclass basic-compile-bundle-op (bundle-op basic-compile-op)
     ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                   :allocation :class)
      (bundle-type :initform :fasl :allocation :class))
@@ -516,6 +516,7 @@ which is probably not what you want; you probably need to tweak your output tran
        (list
         #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
         #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
+        #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib)
         #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
         #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
         #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
@@ -527,27 +528,30 @@ which is probably not what you want; you probably need to tweak your output tran
                      :name (coerce-name name)
                      :static-library (resolve-symlinks* pathname))))
 
+  (defun linkable-system (x)
+    (or (if-let (s (find-system x))
+          (and (system-source-file x) s))
+        (if-let (p (system-module-pathname (coerce-name x)))
+          (make-prebuilt-system x p))))
+
   (defmethod component-depends-on :around ((o image-op) (c system))
-    (let ((next (call-next-method))
-          (deps (make-hash-table :test 'equal)))
-      (loop* :for (do . dcs) :in next :do
-        (loop :for dc :in dcs
-          :for dep = (and dc (resolve-dependency-spec c dc))
-          :when dep :do (setf (gethash (coerce-name (component-system dep)) deps) t)))
-      (labels ((has-it-p (x) (gethash x deps))
-               (ensure-linkable-system (x)
-		 (unless (has-it-p x)
-                   (or (if-let (s (find-system x))
-                         (and (system-source-directory x)
-                              (list s)))
-                       (if-let (p (system-module-pathname x))
-                         (list (make-prebuilt-system x p)))))))
+    (let* ((next (call-next-method))
+           (deps (make-hash-table :test 'equal))
+           (linkable (loop* :for (do . dcs) :in next :collect
+                       (cons do
+                             (loop :for dc :in dcs
+                               :for dep = (and dc (resolve-dependency-spec c dc))
+                               :when dep
+                               :do (setf (gethash (coerce-name (component-system dep)) deps) t)
+                               :collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
         `((lib-op
            ,@(unless (no-uiop c)
-               (append (ensure-linkable-system "cmp")
-                       (or (ensure-linkable-system "uiop")
-                           (ensure-linkable-system "asdf")))))
-          ,@next))))
+               (list (linkable-system "cmp")
+                     (unless (or (gethash "uiop" deps) (gethash "asdf" deps))
+                       (or (linkable-system "uiop")
+                           (linkable-system "asdf")
+                           "asdf")))))
+          ,@linkable)))
 
   (defmethod perform ((o link-op) (c system))
     (let* ((object-files (input-files o c))
diff --git a/test/script-support.lisp b/test/script-support.lisp
index eb7a8a5cc..510c07886 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -173,7 +173,7 @@ Some constraints:
 (defun assert-pathname-equal-helper (qx x qy y)
   (cond
     ((equal x y)
-     (format t "~S and~% ~S both evaluate to same path:~%  ~S~%" qx qy x))
+     (format t "~S and~%~S both evaluate to same path:~%  ~S~%" qx qy x))
     #+mkcl
     ((acall :pathname-equal x y)
      (format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~%  ~S~%and~%  ~S~%" qx qy x y))
diff --git a/test/test-program.script b/test/test-program.script
index 54a9da51b..37ecb3de0 100644
--- a/test/test-program.script
+++ b/test/test-program.script
@@ -131,13 +131,49 @@
     :epilogue-code
     (progn
       (format t "~:[Look ma, no UIOP~;Oops, UIOP~]!~%" (find-package :uiop))
-      (format t "~:[But no TEST-PACKAGE :-(~;But TEST-PACKAGE~]!~%" (find-package :test-package))
+      (format t "~:[But no TEST-PACKAGE :-(~;And TEST-PACKAGE~]!~%" (find-package :test-package))
+      (format t "~:[And no ASDF~;But ASDF :-( ~]!~%" (find-package :asdf))
       #+ecl (si:quit 0) #+mkcl (mk-ext:quit :exit-code 0)))
   (operate 'program-op 'hello-no-uiop :force t)
   (DBG :run (output-file 'program-op 'hello-no-uiop))
   (assert-equal
    (run-program `(,(native-namestring (output-file 'program-op 'hello-no-uiop)))
                 :output :lines :error-output t)
-   '("Look ma, no UIOP!" "But TEST-PACKAGE!")))
+   '("Look ma, no UIOP!" "And TEST-PACKAGE!" "And no ASDF!"))
+
+  (DBG "Now create an program with explicit ASDF dependency, without registered ASDF (use implementation-provided prebuilt)")
+  (trace c::builder) ;; component-depends-on input-files output-files
+  (assert-pathname-equal
+   (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
+   (truename (lisp-implementation-directory)))
+  (def-test-system hello-asdf
+    :class program-system
+    :depends-on ("asdf")
+    :components ((:file "file1"))
+    :epilogue-code
+    (progn
+      (format t "~:[~Oops, no ASDF~;Look ma, ASDF~]!~%" (find-package :asdf))
+      (format t "~:[But no TEST-PACKAGE :-( ~;And TEST-PACKAGE~]!~%" (find-package :test-package))
+      (uiop:quit 0)))
+  (operate 'program-op 'hello-asdf :force t)
+  (DBG :run (output-file 'program-op 'hello-asdf))
+  (assert-equal
+   (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf)))
+                :output :lines :error-output t)
+   '("Look ma, ASDF!" "And TEST-PACKAGE!"))
+
+  (DBG "Now create an program with explicit ASDF dependency")
+  (register-directory *asdf-directory*)
+  (with-asdf-cache (:override t)
+    (load-asd (subpathname *asdf-directory* "asdf.asd")) ;; force re-loading ASDF, from source
+    (assert-pathname-equal
+     (truename (pathname-directory-pathname (output-file 'lib-op (asdf/bundle::linkable-system "asdf"))))
+     (truename (resolve-output "asdf/")))
+    (operate 'program-op 'hello-asdf :force t)
+    (DBG :run (output-file 'program-op 'hello-asdf))
+    (assert-equal
+     (run-program `(,(native-namestring (output-file 'program-op 'hello-asdf)))
+                  :output :lines :error-output t)
+     '("Look ma, ASDF!" "And TEST-PACKAGE!"))))
 
 ;;; TODO: include a regular system dependency and a prebuilt-system in the executable.
-- 
GitLab