From 71f77d62f3c347ffe584e5be69a4ce3004b1f13a Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Fri, 21 Mar 2014 15:00:00 -0400 Subject: [PATCH] Fix image-op and program-op on ECL. Fix test-program.script on allegro. --- bundle.lisp | 8 ++++---- test/test-program.script | 16 ++++++++++++++-- uiop/image.lisp | 3 +-- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/bundle.lisp b/bundle.lisp index 15226f81..f016c9d3 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -492,16 +492,16 @@ itself.")) ;; operation on a system and its dependencies (let* ((object-files (input-files o c)) (output (output-files o c)) (bundle (first output)) - (targetp (eq (type-of o) (component-build-operation c))) + (programp (typep o 'program-op)) (kind (bundle-type o))) (when output (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))) + :prologue-code (or (prologue-code o) (when programp (prologue-code c))) + :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c))) :build-args (bundle-op-build-args o) - (when targetp `(:entry-point ,(component-entry-point c)))))))) + (when programp `(:entry-point ,(component-entry-point c)))))))) #+mkcl (with-upgradability () diff --git a/test/test-program.script b/test/test-program.script index 14d2b4e7..994ca947 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -1,5 +1,4 @@ ;;; -*- Lisp -*- - (DBG :foo (current-lisp-file-pathname)) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t) @@ -8,6 +7,10 @@ (assert (find-system :hello-world-example)) +#+allegro +(defparameter *lisp* + (truename (subpathname #p"sys:" (first (raw-command-line-arguments))))) + ;; Try to load lisp-invocation from xcvb (setf *central-registry* (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF @@ -26,32 +29,37 @@ (DBG "test image-op") (defparameter img (output-file (make-operation 'image-op) (find-system :hello-world-example))) (assert (absolute-pathname-p img)) - (delete-file-if-exists img) +(DBG "- first create an executable image") (assert-equal (nth-value 2 (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist + #+allegro :lisp-path #+allegro *lisp* :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")) :eval "(asdf-test::make-hello-image)") :output t :error-output :output :input nil)) 0) (assert (probe-file* img) () "Can't find image file ~S" img) +(DBG "- then, use it") (assert-equal (nest #+lispworks (last) (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist + #+allegro :lisp-path #+allegro *lisp* :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)") :output :lines :error-output t)) '("hello, world")) +(DBG "- now, use it with arguments") #-(or lispworks scl) ;; These can't be passed arguments the normal way (assert-equal (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist + #+allegro :lisp-path #+allegro *lisp* :image-path (native-namestring img) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" :arguments '("a" "b c" "d")) @@ -74,10 +82,12 @@ (defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example))) (assert (absolute-pathname-p exe)) (delete-file-if-exists exe) +(DBG "- first, create the standalone program") (assert-equal (nth-value 2 (run-program (symbol-call :lisp-invocation :lisp-invocation-arglist + #+allegro :lisp-path #+allegro *lisp* :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")) :eval "(asdf-test::make-hello-program)") :output t :error-output :output :input nil)) @@ -85,9 +95,11 @@ (assert (probe-file* exe) () "Can't find executable file ~S" exe) +(DBG "- use that") (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t) '("hello, world")) +(DBG "- use that with arguments") (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t) '("hello, world" "You passed 3 arguments:" diff --git a/uiop/image.lisp b/uiop/image.lisp index b6a884e2..39a7066e 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -438,8 +438,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ((: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) - )) + (si::top-level t) (quit))) ((:program) `((setf *image-dumped-p* :executable) (shell-boolean-exit -- GitLab