From 007f7609c3c20262bd85f6b2cc5d2aab54dedb48 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Mon, 24 Mar 2014 19:12:31 -0400
Subject: [PATCH] Refactor bundle support for ECL and MKCL.

---
 bundle.lisp                       | 157 +++++++++++++-----------------
 interface.lisp                    |   2 +-
 test/make-hello-world.lisp        |  29 ++++--
 test/test-bundle.script           |   1 +
 test/test-encodings.script        |   4 +
 test/test-logical-pathname.script |   4 +-
 test/test-program.script          |   3 +
 test/test-utilities.script        |   1 -
 uiop/image.lisp                   |  38 +++++---
 9 files changed, 119 insertions(+), 120 deletions(-)

diff --git a/bundle.lisp b/bundle.lisp
index 7c6204cf..582127fa 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -7,7 +7,7 @@
    :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
    :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
   (:export
-   #:bundle-op #:bundle-op-build-args #:bundle-type
+   #:bundle-op #:bundle-type #:program-system
    #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
    #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
    #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
@@ -18,17 +18,16 @@
    #:deliver-asd-op #:monolithic-deliver-asd-op
    #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
    #:user-system-p #:user-system #:trivial-system-p
-   #+ecl #:make-build
-   #:register-pre-built-system
+   #:make-build
    #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
 (in-package :asdf/bundle)
 
 (with-upgradability ()
   (defclass bundle-op (basic-compile-op)
-    ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
+    ((build-args :initarg :args :initform nil :accessor extra-build-args)
      (name-suffix :initarg :name-suffix :initform nil)
      (bundle-type :initform :no-output-file :reader bundle-type)
-     #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)))
+     #+ecl (lisp-files :initform nil :accessor extra-object-files)))
 
   (defclass monolithic-op (operation) ()
     (:documentation "A MONOLITHIC operation operates on a system *and all of its
@@ -39,29 +38,28 @@ itself.")) ;; operation on a system and its dependencies
 
   (defclass monolithic-bundle-op (monolithic-op bundle-op)
     ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
-    ((prologue-code :accessor prologue-code)
-     (epilogue-code :accessor epilogue-code)))
+    ((prologue-code :initform nil :accessor prologue-code)
+     (epilogue-code :initform nil :accessor epilogue-code)))
 
-  (defclass bundle-system (system)
+  (defclass program-system (system)
     ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
-    ((prologue-code :accessor prologue-code)
-     (epilogue-code :accessor epilogue-code)))
-
-  #+mkcl
-  (defclass program (bundle-system)
-    ((prologue-code :initarg :prologue-code :initform nil :accessor prologue-code)
-     (epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code)
+    ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
+     (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
      (prefix-lisp-object-files :initarg :prefix-lisp-object-files
-                               :initform nil :accessor program-prefix-lisp-object-files)
+                               :initform nil :accessor prefix-lisp-object-files)
      (postfix-lisp-object-files :initarg :postfix-lisp-object-files
-                                :initform nil :accessor program-postfix-lisp-object-files)
-     (object-files :initarg :object-files
-                   :initform nil :accessor program-object-files)
+                                :initform nil :accessor postfix-lisp-object-files)
+     (extra-object-files :initarg :extra-object-files
+                         :initform nil :accessor extra-object-files)
      (extra-build-args :initarg :extra-build-args
-                       :initform nil :accessor program-extra-build-args)))
+                       :initform nil :accessor extra-build-args)))
 
   (defmethod prologue-code ((x t)) nil)
   (defmethod epilogue-code ((x t)) nil)
+  (defmethod prefix-lisp-object-files ((x t)) nil)
+  (defmethod postfix-lisp-object-files ((x t)) nil)
+  (defmethod extra-object-files ((x t)) nil)
+  (defmethod extra-build-args ((x t)) nil)
 
   (defclass link-op (bundle-op) ()
     (:documentation "Abstract operation for linking files together"))
@@ -97,7 +95,8 @@ itself.")) ;; operation on a system and its dependencies
     ((bundle-type :initform :lib))
     (:documentation "compile the system and produce linkable (.a) library for it."))
 
-  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation #+ecl link-op #-ecl gather-op)
+  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
+                               #+(or ecl mkcl) link-op #-ecl gather-op)
     ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class)))
 
   (defclass load-bundle-op (basic-load-op selfward-operation)
@@ -123,7 +122,7 @@ itself.")) ;; operation on a system and its dependencies
     (:documentation "produce fasl and asd files for combined system and dependencies."))
 
   (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op
-                                #+ecl link-op gather-op non-propagating-operation)
+                                          #+(or ecl mkcl) link-op gather-op non-propagating-operation)
     ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class))
     (:documentation "Create a single fasl for the system and its dependencies."))
 
@@ -139,7 +138,7 @@ itself.")) ;; operation on a system and its dependencies
     (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
 
   (defclass image-op (monolithic-bundle-op selfward-operation
-                      #+ecl link-op #+(or ecl mkcl) gather-op)
+                      #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op)
     ((bundle-type :initform :image)
      (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
     (:documentation "create an image file from the system and its dependencies"))
@@ -217,8 +216,8 @@ itself.")) ;; operation on a system and its dependencies
         (setf (prologue-code instance) prologue-code
               (epilogue-code instance) epilogue-code)
         #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
-        #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
-    (setf (bundle-op-build-args instance)
+        #+ecl (setf (extra-object-files instance) lisp-files)))
+    (setf (extra-build-args instance)
           (remove-plist-keys
            '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files)
            (operation-original-initargs instance))))
@@ -252,11 +251,6 @@ itself.")) ;; operation on a system and its dependencies
 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
 ;;;
 (with-upgradability ()
-  (defmethod component-depends-on :around ((o bundle-op) (c component))
-    (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
-      `((,op ,c))
-      (call-next-method)))
-
   (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
     ;; This file selects output files from direct dependencies;
     ;; your component-depends-on method better gathered the correct dependencies in the correct order.
@@ -283,7 +277,7 @@ itself.")) ;; operation on a system and its dependencies
       ((:program)
        'program-op)))
 
-  ;; This is originally from asdf-ecl.lisp. Does anyone use it?
+  ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
   (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
                              (move-here nil move-here-p)
                              &allow-other-keys)
@@ -306,7 +300,12 @@ itself.")) ;; operation on a system and its dependencies
                                             :defaults dest-path)
                 :do (rename-file-overwriting-target f new-f)
                 :collect new-f)
-          files))))
+          files)))
+
+  ;; DEPRECATED. Does anyone use this?
+  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+    (declare (ignore force verbose version))
+    (apply #'operate 'deliver-asd-op system args)))
 
 ;;;
 ;;; LOAD-BUNDLE-OP
@@ -315,8 +314,7 @@ itself.")) ;; operation on a system and its dependencies
 ;;;
 (with-upgradability ()
   (defmethod component-depends-on ((o load-bundle-op) (c system))
-    `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
-                  :collect (resolve-dependency-spec c dep)))
+    `((,o ,@(component-sideway-dependencies c))
       (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
       ,@(call-next-method)))
 
@@ -461,38 +459,37 @@ itself.")) ;; operation on a system and its dependencies
 (asdf:load-system :precompiled-asdf-utils)
 |#
 
-#+ecl
-(with-upgradability ()
-  (defun uiop-library-file ()
-    (or (and (find-system :uiop nil)
-             (system-source-directory :uiop)
-             (progn
-               (operate 'lib-op :uiop)
-               (output-file 'lib-op :uiop)))
-        (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
-  (defmethod input-files :around ((o program-op) (c system))
-    (let ((files (call-next-method))
-          (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
-      (unless (or (and (system-source-directory :uiop)
-                       (plan-operates-on-p plan '("uiop")))
-                  (and (system-source-directory :asdf)
-                       (plan-operates-on-p plan '("asdf"))))
-        (pushnew (uiop-library-file) files :test 'pathname-equal))
-      files)))
-
 #+(or ecl mkcl)
 (with-upgradability ()
-  (defun register-pre-built-system (name)
-    (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
-
-#+ecl
-(with-upgradability ()
-  ;; I think that Juanjo intended for this to be.
-  ;; But it might break systems with missing dependencies,
-  ;; and there is a weird bug in test-xach-update-bug.script
-  ;;(unless (use-ecl-byte-compiler-p)
+  ;; I think that Juanjo intended for this to be,
+  ;; but beware the weird bug in test-xach-update-bug.script,
+  ;; and also it makes mkcl fail test-logical-pathname.script,
+  ;; and ecl fail test-bundle.script.
+  ;;(unless (or #+ecl (use-ecl-byte-compiler-p))
   ;;  (setf *load-system-operation* 'load-bundle-op))
 
+  (defun asdf-library-pathname ()
+    #+ecl (compile-file-pathname "sys:asdf" :type :lib)
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
+
+  (defun make-library-system (name pathname)
+    (make-instance 'prebuilt-system :name name :static-library (resolve-symlinks* pathname)))
+
+  (defmethod component-depends-on :around ((o image-op) (c system))
+    (destructuring-bind ((lib-op . deps)) (call-next-method)
+      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
+        `((,lib-op
+           #+mkcl ,@(unless (has-it-p "cmp")
+                      `(,(make-library-system
+                          "cmp" (make-pathname :type (bundle-pathname-type :lib)
+                                               :defaults #p"sys:cmp"))))
+           ,@(unless (or (has-it-p "asdf") (has-it-p "uiop"))
+               `(,(cond
+                    ((system-source-directory :uiop) (find-system :uiop))
+                    ((system-source-directory :asdf) (find-system :asdf))
+                    (t (make-fake-asdf-system "asdf" (asdf-library-pathname))))))
+           ,@deps)))))
+
   (defmethod perform ((o link-op) (c system))
     (let* ((object-files (input-files o c))
            (output (output-files o c))
@@ -501,41 +498,17 @@ itself.")) ;; operation on a system and its dependencies
            (kind (bundle-type o)))
       (when output
         (apply 'create-image
-               bundle (append object-files (bundle-op-lisp-files o))
+               bundle (append
+                       (when programp (prefix-lisp-object-files c))
+                       object-files
+                       (when programp (postfix-lisp-object-files c)))
                :kind kind
                :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
                :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
-               :build-args (bundle-op-build-args o)
+               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
+               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
                (when programp `(:entry-point ,(component-entry-point c))))))))
 
-#+mkcl
-(with-upgradability ()
-  (defmethod perform ((o dll-op) (s system))
-    (apply #'compiler::build-shared-library (output-file o s)
-           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-
-  (defmethod perform ((o lib-op) (s system))
-    (apply #'compiler::build-static-library (output-file o s)
-           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-
-  (defmethod perform ((o basic-compile-bundle-op) (s system))
-    (apply #'compiler::build-bundle (output-file o s)
-           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
-
-  (defmethod perform ((o program-op) (s system))
-    (apply #'compiler::build-program (output-file o s)
-           :lisp-object-files (append (program-prefix-lisp-object-files s)
-                                      (input-files o s)
-                                      (program-postfix-lisp-object-files s))
-           :object-files (program-object-files s)
-           :prologue-code (prologue-code s)
-           :epilogue-code (epilogue-code s)
-           (program-extra-build-args s)))
-
-  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
-    (declare (ignore force verbose version))
-    (apply #'operate 'deliver-asd-op system args)))
-
 #+(and (not asdf-use-unsafe-mac-bundle-op)
        (or (and ecl darwin)
            (and abcl darwin (not abcl-bundle-op-supported))))
diff --git a/interface.lisp b/interface.lisp
index 02690227..13d05223 100644
--- a/interface.lisp
+++ b/interface.lisp
@@ -35,7 +35,7 @@
    #:needed-in-image-p
    #:component-load-dependencies #:run-shell-command ; deprecated, do not use
    #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
-   #+ecl #:make-build
+   #:program-system #:make-build
    #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op
    #:basic-compile-bundle-op #:prepare-bundle-op
    #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp
index 48cfd706..bc312690 100644
--- a/test/make-hello-world.lisp
+++ b/test/make-hello-world.lisp
@@ -10,16 +10,25 @@
 
 (asdf-test::frob-packages)
 
-(defun make-hello-image ()
+#+mkcl
+(defun add-mkcl-dll (pathname)
+  ;; make sure mkcl-X.X.X.dll is the same directory as the executable
+  (let* ((dll-orig (subpathname (si::self-truename)
+                                (strcat #-windows "../lib/"
+                                        "mkcl_" (lisp-implementation-version)
+                                        "." (asdf/bundle:bundle-pathname-type :shared-library))))
+         (dll-dest (subpathname pathname (strcat #-windows "../lib/" (file-namestring dll-orig)))))
+    (ensure-directories-exist dll-dest)
+    (copy-file dll-orig dll-dest)))
+
+
+(defun make-hello-bundle (operation)
   (operate 'load-fasl-op :hello-world-example)
-  (operate 'image-op :hello-world-example))
+  (operate operation :hello-world-example)
+  #+mkcl (add-mkcl-dll (asdf::output-file operation :hello-world-example)))
+
+(defun make-hello-image ()
+  (make-hello-bundle 'image-op))
 
 (defun make-hello-program ()
-  (operate 'load-fasl-op :hello-world-example)
-  (operate 'program-op :hello-world-example)
-  #+(and mkcl windows) ;; make sure mkcl-X.X.X.dll is the same directory as the executable
-  (let* ((dll-orig (subpathname (si::self-truename)
-                                (strcat "mkcl_" (lisp-implementation-version) ".dll")))
-         (exe (asdf::output-file 'program-op :hello-world-example))
-         (dll-dest (subpathname exe dll-orig)))
-    (copy-file dll-orig dll-dest)))
+  (make-hello-bundle 'program-op))
diff --git a/test/test-bundle.script b/test/test-bundle.script
index da8c2658..fe30636e 100644
--- a/test/test-bundle.script
+++ b/test/test-bundle.script
@@ -52,6 +52,7 @@
 ;;; Test dll-op and monolithic-dll-op on ECL and MKCL
 #+(or ecl mkcl)
 (progn
+  #+ecl (trace c::builder)
   (require 'sockets) ;; Test the pre-compiled system feature
   (operate 'dll-op :test-asdf/dll-test)
   (let ((dll (first (output-files 'dll-op :test-asdf/dll-test))))
diff --git a/test/test-encodings.script b/test/test-encodings.script
index 0d9aa54d..5bbbb852 100644
--- a/test/test-encodings.script
+++ b/test/test-encodings.script
@@ -45,6 +45,10 @@
   (when (version< version-nums "1.1.2")
     (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0)))
 
+#+mkcl
+(when (version<= (lisp-implementation-version) "1.1.8")
+  (leave-test "Your old MKCL is known to fail this test script, so skipping it." 0))
+
 (with-encoding-test (:utf-8)
   (def-test-system :test-encoding-explicit-u8
     :components ((:file "lambda" :encoding :utf-8))))
diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script
index 897877ae..b7e54e07 100644
--- a/test/test-logical-pathname.script
+++ b/test/test-logical-pathname.script
@@ -15,7 +15,9 @@
 (DBG :logical
      (logical-pathname-translations "ASDF")
      (translate-logical-pathname "ASDF:test;test-logical-pathname.asd")
-     (truename "ASDF:test;test-logical-pathname.asd"))
+     (truename "ASDF:test;test-logical-pathname.asd")
+     (translate-logical-pathname "ASDF:test;test-logical-pathname.lisp")
+     (translate-logical-pathname "ASDF:test;test-logical-pathname.fasl"))
 
 #+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0)
 
diff --git a/test/test-program.script b/test/test-program.script
index 994ca947..1f97c083 100644
--- a/test/test-program.script
+++ b/test/test-program.script
@@ -1,6 +1,9 @@
 ;;; -*- Lisp -*-
 (DBG :foo (current-lisp-file-pathname))
 
+#+mkcl (trace perform create-image component-depends-on) ;; compiler::build-shared-library compiler::build-static-library compiler::build-bundle compiler::build-program
+#+ecl (trace perform create-image c::builder component-depends-on)
+
 (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
   (DBG "Creating images is not supported on your CL implementation")
   (leave-test "Skipping test" 0))
diff --git a/test/test-utilities.script b/test/test-utilities.script
index b67336f9..dae08789 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -144,7 +144,6 @@
     #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
     ;; on some implementations only
     asdf/bundle:bundle-system
-    asdf/bundle:register-pre-built-system
     asdf/bundle:static-library
     uiop/os:parse-file-location-info
     uiop/os:parse-windows-shortcut
diff --git a/uiop/image.lisp b/uiop/image.lisp
index 39a7066e..6c328ae8 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -416,18 +416,19 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
     (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
            'dump-image filename (nth-value 1 (implementation-type))))
 
-  (defun create-image (destination object-files
-                       &key kind output-name prologue-code epilogue-code
+  (defun create-image (destination lisp-object-files
+                       &key kind output-name prologue-code epilogue-code extra-object-files
                          (prelude () preludep) (postlude () postludep)
                          (entry-point () entry-point-p) build-args)
-    (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
-                        prelude preludep postlude postludep entry-point entry-point-p build-args))
+    (declare (ignorable destination lisp-object-files extra-object-files kind output-name
+                        prologue-code epilogue-code prelude preludep postlude postludep
+                        entry-point entry-point-p build-args))
     "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
     ;; Is it meaningful to run these in the current environment?
     ;; only if we also track the object files that constitute the "current" image,
     ;; and otherwise simulate dump-image, including quitting at the end.
-    #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
-    #+ecl
+    #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
+    #+(or ecl mkcl)
     (let ((epilogue-forms
             (append
              (when epilogue-code `(,epilogue-code))
@@ -438,19 +439,26 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
                ((:image)
                 (setf kind :program) ;; to ECL, it's just another program.
                 `((setf *image-dumped-p* t)
-                  (si::top-level t) (quit)))
+                  (si::top-level #+ecl t) (quit)))
                ((:program)
                 `((setf *image-dumped-p* :executable)
                   (shell-boolean-exit
                    (restore-image))))))))
-      (check-type kind (member :dll :lib :static-library :program :object :fasl :program))
-      (apply 'c::builder
-             kind (pathname destination)
-             :lisp-files object-files
-             :init-name (c::compute-init-name (or output-name destination) :kind kind)
-             :prologue-code prologue-code
-             :epilogue-code (when epilogue-forms `(progn ,@epilogue-forms))
-             build-args))))
+      #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
+      (apply #+ecl 'c::builder #+ecl kind
+             #+mkcl (ecase kind
+                      ((:dll) 'compiler::build-shared-library)
+                      ((:lib :static-library) 'compiler::build-static-library)
+                      ((:fasl) 'compiler::build-bundle)
+                      ((:program) 'compiler::build-program))
+             (pathname destination)
+             #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
+             #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
+             (append
+              (when prologue-code `(:prologue-code ,prologue-code))
+              (when epilogue-forms `(:epilogue-code (progn ,@epilogue-forms)))
+              #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
+              build-args)))))
 
 
 ;;; Some universal image restore hooks
-- 
GitLab