diff --git a/bin/install-asdf-as-module b/bin/install-asdf-as-module index dcc270d22c5fa170169db07845a48ff964ca5859..62cafaca19240fcc857bc45dd71c334afba1b8f0 100644 --- a/bin/install-asdf-as-module +++ b/bin/install-asdf-as-module @@ -1,6 +1,6 @@ ":" ; exec cl-launch "$0" "$@" #| -*- Lisp -*- -Usage: cl-launch -l lispworks install-asdf-as-module +Usage: make && cl-launch -l lispworks bin/install-asdf-as-module This script will install the current version of ASDF as a module pre-compiled for your implementation, diff --git a/bundle.lisp b/bundle.lisp index 71fe5c5fd91963bd6616f824ff8f442b86889a96..303461f1151b96934530a7edfca156037787bf3d 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -13,8 +13,8 @@ #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:lib-op #:monolithic-lib-op #:dll-op #:monolithic-dll-op - #:binary-op #:monolithic-binary-op - #:program-op #:compiled-file #:precompiled-system #:prebuilt-system + #: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 @@ -22,7 +22,7 @@ (in-package :asdf/bundle) (with-upgradability () - (defclass bundle-op (operation) + (defclass bundle-op (basic-compile-op) ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) @@ -30,79 +30,104 @@ #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) - (defclass bundle-compile-op (bundle-op basic-compile-op) - () - (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) + (defclass monolithic-op (operation) () + (:documentation "A MONOLITHIC operation operates on a system *and all of its +dependencies*. So, for example, a monolithic concatenate operation will +concatenate together a system's components and all of its dependencies, but a +simple concatenate operation will concatenate only the components of the system +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))) + + (defclass bundle-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))) + + (defmethod prologue-code ((x t)) nil) + (defmethod epilogue-code ((x t)) nil) + + (defclass link-op (bundle-op) () + (:documentation "Abstract operation for linking files together")) + + (defclass gather-op (bundle-op) + ((gather-op :initform nil :allocation :class :reader gather-op)) + (:documentation "Abstract operation for gathering many input files from a system")) + + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) + + (defmethod component-depends-on ((o gather-op) (s system)) + (let* ((mono (operation-monolithic-p o)) + (deps + (required-components + s :other-systems mono :component-type (if mono 'system '(not system)) + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op))) + ;; NB: the explicit make-operation on ECL and MKCL + ;; ensures that we drop the original-initargs and its magic flags when recursing. + `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps) + ,@(call-next-method)))) ;; create a single fasl for the entire library - (defclass basic-fasl-op (bundle-compile-op) + (defclass basic-fasl-op (bundle-op) ((bundle-type :initform :fasl))) + (defclass prepare-fasl-op (sideway-operation) - ((sideway-operation :initform 'load-fasl-op :allocation :class))) - (defclass fasl-op (basic-fasl-op selfward-operation) + ((sideway-operation :initform #+ecl 'load-fasl-op #-ecl 'load-op :allocation :class))) + + (defclass lib-op (link-op gather-op non-propagating-operation) + ((bundle-type :initform :lib)) + (:documentation "compile the system and produce linkable (.a) library for it.")) + + (defclass fasl-op (basic-fasl-op selfward-operation #+ecl link-op #-ecl gather-op) ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op) :allocation :class))) + (defclass load-fasl-op (basic-load-op selfward-operation) ((selfward-operation :initform '(prepare-op fasl-op) :allocation :class))) ;; NB: since the monolithic-op's can't be sideway-operation's, - ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's, + ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, ;; we'd have to have the monolithic-op not inherit from the main op, ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above. - (defclass no-ld-flags-op (operation) ()) - - (defclass lib-op (bundle-compile-op no-ld-flags-op non-propagating-operation) - ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) - (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it." - #-(or ecl mkcl) "just compile the system")) - - (defclass dll-op (bundle-compile-op no-ld-flags-op non-propagating-operation) + (defclass dll-op (link-op gather-op non-propagating-operation) ((bundle-type :initform :dll)) (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) - (defclass binary-op (basic-compile-op selfward-operation) - ((selfward-operation :initform '(fasl-op lib-op) :allocation :class)) - (:documentation "produce fasl and asd files for the system")) - - (defclass monolithic-op (operation) () - (:documentation "A MONOLITHIC operation operates on a system *and all of its -dependencies*. So, for example, a monolithic concatenate operation will -concatenate together a system's components and all of its dependencies, but a -simple concatenate operation will concatenate only the components of the system -itself.")) ;; operation on a system and its dependencies - - (defclass monolithic-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) + (defclass deliver-asd-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op #+(or ecl mkcl) lib-op) :allocation :class)) + (:documentation "produce an asd file for delivering the system as a single fasl")) - (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op) - () - (:documentation "Abstract operation for ways to bundle the outputs of compiling -*Lisp* files over a system, and all of its dependencies.")) - (defclass monolithic-binary-op (monolithic-op binary-op) - ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op) :allocation :class)) + (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) + ((selfward-operation :initform '(monolithic-fasl-op #+(or ecl mkcl) monolithic-lib-op) + :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) - (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op non-propagating-operation) () + (defclass monolithic-fasl-op (monolithic-bundle-op basic-fasl-op + #+ecl link-op gather-op non-propagating-operation) + ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'fasl-op :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) - (defclass monolithic-lib-op (monolithic-bundle-compile-op non-propagating-operation no-ld-flags-op) - ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) - (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies." - #-(or ecl mkcl) "Compile a system and its dependencies.")) + (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) () + (:documentation "Create a single linkable library for the system and its dependencies.")) - (defclass monolithic-dll-op (monolithic-bundle-compile-op non-propagating-operation no-ld-flags-op) + (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation) ((bundle-type :initform :dll)) (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) - ;; Fare reports that the PROGRAM-OP doesn't need any propagation on MKCL or - ;; ECL because the necessary dependency wrangling is done by other, earlier - ;; operations. [2014/01/20:rpg] - (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op non-propagating-operation) - #-(or mkcl ecl) (monolithic-bundle-op selfward-operation) - ((bundle-type :initform :program) - #-(or mkcl ecl) (selfward-operation :initform 'load-op)) + (defclass image-op (monolithic-bundle-op selfward-operation + #+ecl link-op #+(or ecl mkcl) gather-op) + ((bundle-type :initform :image) + (selfward-operation :initform '(#-ecl load-op) :allocation :class)) + (:documentation "create an image file from the system and its dependencies")) + + (defclass program-op (image-op) + ((bundle-type :initform :program)) (:documentation "create an executable file from the system and its dependencies")) (defun bundle-pathname-type (bundle-type) @@ -111,22 +136,22 @@ itself.")) ;; operation on a system and its dependencies ((or null string) bundle-type) ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") #+ecl - ((member :binary :dll :lib :shared-library :static-library :program :object :program) + ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) - ((eql :binary) "image") + ((member :image) "image") ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (defun bundle-output-files (o c) - (when (input-files o c) - (let ((bundle-type (bundle-type o))) - (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. - (let ((name (or (component-build-pathname c) - (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) - (type (bundle-pathname-type bundle-type))) - (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c)))))))) + (let ((bundle-type (bundle-type o))) + (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) + (let ((name (or (component-build-pathname c) + (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (type-of o) (component-build-operation c))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) @@ -157,9 +182,6 @@ itself.")) ;; operation on a system and its dependencies ;;; The different targets are defined by specialization. ;;; (with-upgradability () - (defun operation-monolithic-p (op) - (typep op 'monolithic-op)) - (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key (name-suffix nil name-suffix-p) &allow-other-keys) @@ -169,25 +191,17 @@ itself.")) ;; operation on a system and its dependencies (unless (typep instance 'program-op) (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code + (destructuring-bind (&key lisp-files prologue-code epilogue-code &allow-other-keys) (operation-original-initargs instance) - (setf (operation-original-initargs instance) - (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) - (monolithic-op-prologue-code instance) prologue-code - (monolithic-op-epilogue-code instance) epilogue-code) + (setf (prologue-code instance) prologue-code + (epilogue-code instance) epilogue-code) #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) (setf (bundle-op-build-args instance) - (remove-plist-keys '(:type :monolithic :name-suffix) - (operation-original-initargs instance)))) - - (defmethod bundle-op-build-args :around ((o no-ld-flags-op)) - #+xcl (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) + (remove-plist-keys + '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files) + (operation-original-initargs instance)))) (defun bundlable-file-p (pathname) (let ((type (pathname-type pathname))) @@ -216,18 +230,6 @@ itself.")) ;; operation on a system and its dependencies ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () - (defmethod component-depends-on ((o bundle-compile-op) (c system)) - `(,(if (operation-monolithic-p o) - `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op - ,@(required-components c :other-systems t :component-type 'system - :goal-operation (find-operation o 'load-op) - :keep-operation 'compile-op)) - `(compile-op - ,@(required-components c :other-systems nil :component-type '(not system) - :goal-operation (find-operation o 'load-op) - :keep-operation 'compile-op))) - ,@(call-next-method))) - (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)) @@ -242,23 +244,24 @@ itself.")) ;; operation on a system and its dependencies (loop :for f :in (funcall key sub-o sub-c) :when (funcall test f) :do (collect f)))))) - (defmethod input-files ((o bundle-compile-op) (c system)) + (defmethod input-files ((o bundle-op) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) (defun select-bundle-operation (type &optional monolithic) (ecase type - ((:binary) - (if monolithic 'monolithic-binary-op 'binary-op)) ((:dll :shared-library) (if monolithic 'monolithic-dll-op 'dll-op)) ((:lib :static-library) (if monolithic 'monolithic-lib-op 'lib-op)) ((:fasl) (if monolithic 'monolithic-fasl-op 'fasl-op)) + ((:image) + 'image-op) ((:program) 'program-op))) + ;; 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) @@ -273,7 +276,7 @@ itself.")) ;; operation on a system and its dependencies (system (find-system system)) (files (and system (output-files operation system)))) (if (or move-here (and (null move-here-p) - (member operation-name '(:program :binary)))) + (member operation-name '(:program :image)))) (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) :for f :in files :for new-f = (make-pathname :name (pathname-name f) @@ -348,11 +351,11 @@ itself.")) ;; operation on a system and its dependencies ;;; PREBUILT SYSTEM CREATOR ;;; (with-upgradability () - (defmethod output-files ((o binary-op) (s system)) + (defmethod output-files ((o deliver-asd-op) (s system)) (list (make-pathname :name (component-name s) :type "asd" :defaults (component-pathname s)))) - (defmethod perform ((o binary-op) (s system)) + (defmethod perform ((o deliver-asd-op) (s system)) (let* ((inputs (input-files o s)) (fasl (first inputs)) (library (second inputs)) @@ -394,7 +397,7 @@ itself.")) ;; operation on a system and its dependencies (terpri s))))) #-(or ecl mkcl) - (defmethod perform ((o bundle-compile-op) (c system)) + (defmethod perform ((o basic-fasl-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) @@ -405,8 +408,8 @@ itself.")) ;; operation on a system and its dependencies (when non-fasl-files (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" (implementation-type) non-fasl-files)) - (when (and (typep o 'monolithic-bundle-op) - (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) + (when (or (prologue-code o) (epilogue-code o) + (prologue-code c) (epilogue-code c)) (error "prologue-code and epilogue-code are not supported on ~A" (implementation-type))) (with-staging-pathname (output-file) @@ -439,8 +442,7 @@ itself.")) ;; operation on a system and its dependencies (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 (find-system :uiop nil) - (system-source-directory :uiop) + (unless (or (and (system-source-directory :uiop) (plan-operates-on-p plan '("uiop"))) (and (system-source-directory :asdf) (plan-operates-on-p plan '("asdf")))) @@ -452,23 +454,20 @@ itself.")) ;; operation on a system and its dependencies #+ecl (with-upgradability () - (defmethod perform ((o bundle-compile-op) (c system)) + (defmethod perform ((o link-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) + (targetp (eq (type-of o) (component-build-operation c))) (kind (bundle-type o))) (when output - (create-image - bundle (append object-files (bundle-op-lisp-files o)) - :kind kind - :entry-point (component-entry-point c) - :prologue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-prologue-code o)) - :epilogue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - :build-args (bundle-op-build-args o)))))) + (apply 'create-image + bundle (append object-files (bundle-op-lisp-files o)) + :kind kind + :prologue-code (or (prologue-code o) (when targetp (prologue-code c))) + :epilogue-code (or (epilogue-code o) (when targetp (epilogue-code c))) + :build-args (bundle-op-build-args o) + (when targetp `(:entry-point ,(component-entry-point c)))))))) #+mkcl (with-upgradability () @@ -482,7 +481,7 @@ itself.")) ;; operation on a system and its dependencies (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) (declare (ignore force verbose version)) - (apply #'operate 'binary-op system args))) + (apply #'operate 'deliver-asd-op system args))) #+(and (not asdf-use-unsafe-mac-bundle-op) (or (and ecl darwin) diff --git a/interface.lisp b/interface.lisp index 2468aabf1efc626f01afb14e93e610172e2ab098..e2946895d9d73fadf4d97cb2a57a86264878e8c1 100644 --- a/interface.lisp +++ b/interface.lisp @@ -40,8 +40,8 @@ #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #+ecl #:make-build #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op - #:lib-op #:dll-op #:binary-op #:program-op - #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op + #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op diff --git a/operate.lisp b/operate.lisp index a1dda00be1b00af724bde6a3913dbca80079dd21..79ac3f8eeed1990c256589d0567631ca31b3550b 100644 --- a/operate.lisp +++ b/operate.lisp @@ -58,6 +58,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (operation-name (reify-symbol (etypecase operation (operation (type-of operation)) (symbol operation)))) + (operation-initargs (operation-original-initargs operation)) (component-path (typecase component (component (component-find-path component)) (t component)))) @@ -69,7 +70,9 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ;; its function may have been redefined, its symbol uninterned, its package deleted. (return-from operate (apply (find-symbol* 'operate :asdf) - (unreify-symbol operation-name) + (apply (find-symbol* 'make-operation :asdf) + (unreify-symbol operation-name) + :original-initargs operation-initargs operation-initargs) component-path keys)))) ;; Setup proper bindings around any operate call. (with-system-definitions () diff --git a/test/hello.lisp b/test/hello.lisp index f50a3ad8f2f937bef815ee3066baa4d9a2d502ef..7bcdaf9c994b75ea81accf37ac61303ae3ac36e0 100644 --- a/test/hello.lisp +++ b/test/hello.lisp @@ -7,7 +7,9 @@ (defun main (&rest arguments) (format t "hello, world~%") (when arguments - (format t "You passed ~D arguments:~%~{ ~S~%~}" (length arguments) arguments))) + (format t "You passed ~D arguments:~%~{ ~S~%~}" (length arguments) arguments)) + ;; Return success! + t) (defun entry-point () (apply 'main *command-line-arguments*)) diff --git a/test/test-bundle.script b/test/test-bundle.script index d51a9d25bac281019f2e8bebb01bc133c0551c7f..6e2bca8951d85aa653c7cc1e0028aba765906e31 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -29,7 +29,6 @@ (when (version< version-nums "1.2.0") (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0))) - (defparameter *bundle-1* (output-file 'fasl-op :test-asdf/bundle-1)) (defparameter *bundle-2* (output-file 'fasl-op :test-asdf/bundle-2)) (defparameter *mono-bundle-2* (output-file 'monolithic-fasl-op :test-asdf/bundle-2)) diff --git a/test/test-operation-classes.script b/test/test-operation-classes.script index c7599d15ce751d00ec308363ce789abdeb2855b1..8482596ee99c7382d5b4220d56df86be746795e6 100644 --- a/test/test-operation-classes.script +++ b/test/test-operation-classes.script @@ -11,31 +11,32 @@ (defparameter *good-classes* '(build-op - prepare-source-op - prepare-op - prepare-fasl-op - load-op - monolithic-load-compiled-concatenated-source-op - prepare-fasl-op - load-source-op + compile-concatenated-source-op + compile-op + concatenate-source-op + deliver-asd-op + dll-op + fasl-op + image-op + lib-op load-compiled-concatenated-source-op - monolithic-load-concatenated-source-op load-concatenated-source-op load-fasl-op - compile-op - compile-concatenated-source-op - test-op - fasl-op - program-op + load-op + load-source-op monolithic-compile-concatenated-source-op + monolithic-concatenate-source-op + monolithic-deliver-asd-op monolithic-dll-op - monolithic-binary-op monolithic-fasl-op - dll-op - concatenate-source-op monolithic-lib-op - monolithic-concatenate-source-op - lib-op) + monolithic-load-compiled-concatenated-source-op + monolithic-load-concatenated-source-op + prepare-fasl-op + prepare-op + prepare-source-op + program-op + test-op) "All of these classes should be instantiable without error.") (defclass my-unupdated-operation (operation) diff --git a/uiop/image.lisp b/uiop/image.lisp index bc9e42519da382bfe0378e681b617869b949a298..3d9e320a2328aa1af80c06fa86fa4c2b11cb8389 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -243,7 +243,10 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" Assume the calling conventions of a generated script that uses -- if we are not called from a directly executable image." #+abcl arguments - #-abcl + ;; LispWorks command-line processing isn't transparent to the user, and + ;; we need to rely on cl-launch or some other script to set it for us. + #+lispworks *command-line-arguments* + #-(or abcl lispworks) (let* (#-(or sbcl allegro) (arguments (if (eq *image-dumped-p* :executable) @@ -377,21 +380,29 @@ by setting appropriate variables, running various hooks, and calling any specifi ;; and otherwise simulate dump-image, including quitting at the end. #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) #+ecl - (progn - (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) + (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) + ;; fall through should be equivalent to: (si::top-level 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 - `(progn - ,epilogue-code - ,@(when (eq kind :program) - `((setf *image-dumped-p* :executable) - (restore-image ;; default behavior would be (si::top-level) - ,@(when preludep `(:prelude ',prelude)) - ,@(when entry-point-p `(:entry-point ',entry-point)))))) + :epilogue-code (when epilogue-forms `(progn ,@epilogue-forms)) build-args))))