diff --git a/bundle.lisp b/bundle.lisp index e46a668eed06a4292fa42c389397d6f6bdc47d1e..91af8803e5cc7d6930d4647d18f67559545c5c41 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 8a027229229e7011ae2345352b330ec1e4a4beba..eb9e5eb49ff1dbf4ac2b180dd5ae75f94a83a546 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 6c328ae8b08ed4dc6e5d8793a1902a90a4c1ec4e..50a6a216c5b4532fa262a69301ec4066ec7cf503 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)))))