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