Commit e4de8bff authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Add option on ECL and MKCL to build images without UIOP, plus test.

parent e2751f31
......@@ -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)
......
;;; -*- 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.
......@@ -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)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment