From 81438c4879cd3bd7d7bcea7b00fc5f20346b761f Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 17 Mar 2014 16:01:34 -0400 Subject: [PATCH] Some cleanups after MKCL support. --- asdf.asd | 2 +- bundle.lisp | 18 ++++++++---------- test/hello-world-example.asd | 32 ++++++++++++-------------------- test/hello.lisp | 3 +-- uiop/image.lisp | 2 +- 5 files changed, 23 insertions(+), 34 deletions(-) diff --git a/asdf.asd b/asdf.asd index 940485c7..2c941b75 100644 --- a/asdf.asd +++ b/asdf.asd @@ -58,7 +58,7 @@ (:file "source-registry" :depends-on ("find-system")) (:file "backward-internals" :depends-on ("lisp-action" "operate")) (:file "parse-defsystem" :depends-on ("backward-internals" "cache" "system")) - (:file "bundle" :depends-on ("lisp-action" "operate")) + (:file "bundle" :depends-on ("lisp-action" "operate" "parse-defsystem")) (:file "concatenate-source" :depends-on ("plan" "parse-defsystem" "bundle")) (:file "backward-interface" :depends-on ("operate" "output-translations")) (:file "package-system" :depends-on ("system" "find-system" "parse-defsystem")) diff --git a/bundle.lisp b/bundle.lisp index 27696b57..15226f81 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -5,7 +5,7 @@ (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files @@ -47,8 +47,7 @@ itself.")) ;; operation on a system and its dependencies #+mkcl (defclass program (bundle-system) - ( - (prologue-code :initarg :prologue-code :initform nil :accessor prologue-code) + ((prologue-code :initarg :prologue-code :initform nil :accessor prologue-code) (epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code) (prefix-lisp-object-files :initarg :prefix-lisp-object-files :initform nil :accessor program-prefix-lisp-object-files) @@ -205,12 +204,12 @@ itself.")) ;; operation on a system and its dependencies (unless (typep instance 'program-op) (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&key #-mkcl lisp-files prologue-code epilogue-code + (destructuring-bind (&key lisp-files prologue-code epilogue-code &allow-other-keys) (operation-original-initargs instance) (setf (prologue-code instance) prologue-code (epilogue-code instance) epilogue-code) - #-(or ecl mkcl) (assert (null (or lisp-files epilogue-code prologue-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) (remove-plist-keys @@ -357,20 +356,19 @@ itself.")) ;; operation on a system and its dependencies nil) (defmethod perform ((o basic-fasl-op) (c prebuilt-system)) - nil)) + nil) (defmethod perform ((o lib-op) (c prebuilt-system)) nil) (defmethod perform ((o dll-op) (c prebuilt-system)) - nil)) + nil) (defmethod component-depends-on ((o gather-op) (c prebuilt-system)) nil) (defmethod output-files ((o lib-op) (c prebuilt-system)) - (values (list (prebuilt-system-static-library c)) t)) - + (values (list (prebuilt-system-static-library c)) t))) ;;; @@ -415,7 +413,7 @@ itself.")) ;; operation on a system and its dependencies (machine-type) (software-version)) (let ((*package* (find-package :asdf-user))) - (pprint `(asdf/defsystem:defsystem ,name + (pprint `(defsystem ,name :class prebuilt-system :version ,version :depends-on ,depends-on diff --git a/test/hello-world-example.asd b/test/hello-world-example.asd index d7deb19f..90aa5556 100644 --- a/test/hello-world-example.asd +++ b/test/hello-world-example.asd @@ -1,22 +1,14 @@ ;; Example executable program -#-mkcl -(defsystem :hello-world-example - ;; :build-operation program-op ; this would cause the executable output in same directory :-/ - :entry-point "hello:entry-point" - :depends-on (:uiop) - :components ((:file "hello"))) - -#+mkcl -(defsystem :hello-world-example - :class asdf/bundle::program - :build-operation program-op - :entry-point "hello:entry-point" - :depends-on (:uiop) - :components ((:file "hello")) - :prefix-lisp-object-files #.(list (namestring (truename (translate-logical-pathname #P"SYS:cmp.a")))) - :extra-build-args #.(or #-windows '(:use-mkcl-shared-libraries nil)) - :epilogue-code (progn - (setq uiop/image:*image-dumped-p* :executable) - (uiop/image:restore-image :entry-point (read-from-string "hello:entry-point")))) - +#.`(defsystem :hello-world-example + ;; :build-operation program-op ; this would cause the executable output in same directory :-/ + :entry-point "hello:entry-point" + :depends-on (:uiop) + :components ((:file "hello")) + #+mkcl + ,@`(:prefix-lisp-object-files (,(namestring (truename (translate-logical-pathname #P"SYS:cmp.a")))) + :extra-build-args ,(or #-windows '(:use-mkcl-shared-libraries nil)) + :epilogue-code (progn + (setq uiop/image:*image-dumped-p* :executable) + (setq uiop/image:*lisp-interaction* nil) + (uiop/image:restore-image :entry-point (read-from-string "hello:entry-point"))))) diff --git a/test/hello.lisp b/test/hello.lisp index edae1073..7bcdaf9c 100644 --- a/test/hello.lisp +++ b/test/hello.lisp @@ -12,5 +12,4 @@ t) (defun entry-point () - (apply 'main *command-line-arguments*) - #+mkcl (quit)) + (apply 'main *command-line-arguments*)) diff --git a/uiop/image.lisp b/uiop/image.lisp index c7100266..b6a884e2 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -264,7 +264,7 @@ return a string that for the name with which the program was invoked, i.e. argv[ Otherwise, return NIL." (cond ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! - ;; NB: not currently available on ABCL, Corman, Genera, MCL, MKCL + ;; NB: not currently available on ABCL, Corman, Genera, MCL (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) #+ecl (si:argv 0) #+mkcl (mkcl:argv 0))) -- GitLab