From e4de8bffbb30a701a6a679ea2d226777a3669b06 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Tue, 25 Mar 2014 12:02:18 -0400
Subject: [PATCH] Add option on ECL and MKCL to build images without UIOP, plus
 test.

---
 bundle.lisp              | 26 +++++++++++++++++---------
 test/test-program.script | 24 +++++++++++++++++++++---
 uiop/image.lisp          | 38 +++++++++++++++++++++-----------------
 3 files changed, 59 insertions(+), 29 deletions(-)

diff --git a/bundle.lisp b/bundle.lisp
index e46a668e..91af8803 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -45,6 +45,7 @@ itself.")) ;; operation on a system and its dependencies
     ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
     ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
      (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
+     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
      (prefix-lisp-object-files :initarg :prefix-lisp-object-files
                                :initform nil :accessor prefix-lisp-object-files)
      (postfix-lisp-object-files :initarg :postfix-lisp-object-files
@@ -56,6 +57,7 @@ itself.")) ;; operation on a system and its dependencies
 
   (defmethod prologue-code ((x t)) nil)
   (defmethod epilogue-code ((x t)) nil)
+  (defmethod no-uiop ((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)
@@ -219,7 +221,8 @@ itself.")) ;; operation on a system and its dependencies
         #+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)
+           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
+             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
            (operation-original-initargs instance))))
 
   (defun bundlable-file-p (pathname)
@@ -469,25 +472,29 @@ itself.")) ;; operation on a system and its dependencies
   ;;  (setf *load-system-operation* 'load-bundle-op))
 
   (defun asdf-library-pathname ()
-    #+ecl (compile-file-pathname "sys:asdf" :type :lib)
+    #+ecl (compile-file-pathname "sys:asdf" :type :object)
     #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
 
+  (defun compiler-library-pathname ()
+    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
+
   (defun make-library-system (name pathname)
-    (make-instance 'prebuilt-system :name name :static-library (resolve-symlinks* pathname)))
+    (make-instance 'prebuilt-system
+                   :name (coerce-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"))
+           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
+               `(,(make-library-system
+                   "cmp" (compiler-library-pathname))))
+           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
                `(,(cond
                     ((system-source-directory :uiop) (find-system :uiop))
                     ((system-source-directory :asdf) (find-system :asdf))
-                    (t (make-fake-asdf-system "asdf" (asdf-library-pathname))))))
+                    (t (make-library-system "asdf" (asdf-library-pathname))))))
            ,@deps)))))
 
   (defmethod perform ((o link-op) (c system))
@@ -507,6 +514,7 @@ itself.")) ;; operation on a system and its dependencies
                :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
                :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)))
+               :no-uiop (no-uiop c)
                (when programp `(:entry-point ,(component-entry-point c))))))))
 
 #+(and (not asdf-use-unsafe-mac-bundle-op)
diff --git a/test/test-program.script b/test/test-program.script
index 8a027229..eb9e5eb4 100644
--- a/test/test-program.script
+++ b/test/test-program.script
@@ -1,9 +1,6 @@
 ;;; -*- 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))
@@ -112,4 +109,25 @@
                 "  \"b c\""
                 "  \"d\""))
 
+#+(or ecl mkcl)
+(progn
+  (DBG "Now create an program without UIOP")
+  (assert (probe-file (asdf/bundle::asdf-library-pathname)))
+  (assert (probe-file (asdf/bundle::compiler-library-pathname)))
+  (def-test-system hello-no-uiop
+    :class program-system
+    :no-uiop t
+    :components ((:file "file1"))
+    :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))
+      #+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!")))
+
 ;;; TODO: include a regular system dependency and a prebuilt-system in the executable.
diff --git a/uiop/image.lisp b/uiop/image.lisp
index 6c328ae8..50a6a216 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -419,7 +419,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
   (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)
+                         (entry-point () entry-point-p) build-args no-uiop)
     (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))
@@ -429,21 +429,25 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
     ;; and otherwise simulate dump-image, including quitting at the end.
     #-(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))
-             (when postludep `((setf *image-postlude* ',postlude)))
-             (when preludep `((setf *image-prelude* ',prelude)))
-             (when entry-point-p `((setf *image-entry-point* ',entry-point)))
-             (case kind
-               ((:image)
-                (setf kind :program) ;; to ECL, it's just another program.
-                `((setf *image-dumped-p* t)
-                  (si::top-level #+ecl t) (quit)))
-               ((:program)
-                `((setf *image-dumped-p* :executable)
-                  (shell-boolean-exit
-                   (restore-image))))))))
+    (let ((epilogue-code
+            (if no-uiop
+                epilogue-code
+                (let ((forms
+                        (append
+                         (when epilogue-code `(,epilogue-code))
+                         (when postludep `((setf *image-postlude* ',postlude)))
+                         (when preludep `((setf *image-prelude* ',prelude)))
+                         (when entry-point-p `((setf *image-entry-point* ',entry-point)))
+                         (case kind
+                           ((:image)
+                            (setf kind :program) ;; to ECL, it's just another program.
+                            `((setf *image-dumped-p* t)
+                              (si::top-level #+ecl t) (quit)))
+                           ((:program)
+                            `((setf *image-dumped-p* :executable)
+                              (shell-boolean-exit
+                               (restore-image))))))))
+                  (when forms `(progn ,@forms))))))
       #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
       (apply #+ecl 'c::builder #+ecl kind
              #+mkcl (ecase kind
@@ -456,7 +460,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
              #+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)))
+              (when epilogue-code `(:epilogue-code ,epilogue-code))
               #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
               build-args)))))
 
-- 
GitLab