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

Fix image-op and program-op on ECL. 

Fix test-program.script on allegro.
parent 1e9eccfd

bundle.lisp

+4 −4
Original line number Original line Diff line number Diff line
@@ -492,16 +492,16 @@ itself.")) ;; operation on a system and its dependencies 
    (let* ((object-files (input-files o c))

    (let* ((object-files (input-files o c))

           (output (output-files o c))

           (output (output-files o c))

           (bundle (first output))

           (bundle (first output))

           (targetp (eq (type-of o) (component-build-operation c)))

           (programp (typep o 'program-op))

           (kind (bundle-type o)))

           (kind (bundle-type o)))

      (when output

      (when output

        (apply 'create-image

        (apply 'create-image

               bundle (append object-files (bundle-op-lisp-files o))

               bundle (append object-files (bundle-op-lisp-files o))

               :kind kind

               :kind kind

               :prologue-code (or (prologue-code o) (when targetp (prologue-code c)))

               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))

               :epilogue-code (or (epilogue-code o) (when targetp (epilogue-code c)))

               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))

               :build-args (bundle-op-build-args o)

               :build-args (bundle-op-build-args o)

               (when targetp `(:entry-point ,(component-entry-point c))))))))

               (when programp `(:entry-point ,(component-entry-point c))))))))





#+mkcl

#+mkcl

(with-upgradability ()

(with-upgradability ()

test/test-program.script

+14 −2
Original line number Original line Diff line number Diff line 
;;; -*- Lisp -*-

;;; -*- Lisp -*-



(DBG :foo (current-lisp-file-pathname))

(DBG :foo (current-lisp-file-pathname))





(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)

(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))

(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

;; Try to load lisp-invocation from xcvb

(setf *central-registry*

(setf *central-registry*

      (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF

      (list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF
@@ -26,32 +29,37 @@ 
(DBG "test image-op")

(DBG "test image-op")

(defparameter img (output-file (make-operation 'image-op) (find-system :hello-world-example)))

(defparameter img (output-file (make-operation 'image-op) (find-system :hello-world-example)))

(assert (absolute-pathname-p img))

(assert (absolute-pathname-p img))



(delete-file-if-exists img)

(delete-file-if-exists img)

(DBG "- first create an executable image")

(assert-equal

(assert-equal

 (nth-value 2

 (nth-value 2

  (run-program

  (run-program

   (symbol-call :lisp-invocation :lisp-invocation-arglist

   (symbol-call :lisp-invocation :lisp-invocation-arglist

                #+allegro :lisp-path #+allegro *lisp*

                :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))

                :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))

                :eval "(asdf-test::make-hello-image)")

                :eval "(asdf-test::make-hello-image)")

   :output t :error-output :output :input nil))

   :output t :error-output :output :input nil))

 0)

 0)

(assert (probe-file* img) () "Can't find image file ~S" img)

(assert (probe-file* img) () "Can't find image file ~S" img)





(DBG "- then, use it")

(assert-equal

(assert-equal

 (nest

 (nest

  #+lispworks (last)

  #+lispworks (last)

  (run-program

  (run-program

   (symbol-call :lisp-invocation :lisp-invocation-arglist

   (symbol-call :lisp-invocation :lisp-invocation-arglist

                #+allegro :lisp-path #+allegro *lisp*

		:image-path (native-namestring img)

		:image-path (native-namestring img)

		:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")

		:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")

   :output :lines :error-output t))

   :output :lines :error-output t))

 '("hello, world"))

 '("hello, world"))





(DBG "- now, use it with arguments")

#-(or lispworks scl) ;; These can't be passed arguments the normal way

#-(or lispworks scl) ;; These can't be passed arguments the normal way

(assert-equal

(assert-equal

 (run-program

 (run-program

  (symbol-call :lisp-invocation :lisp-invocation-arglist

  (symbol-call :lisp-invocation :lisp-invocation-arglist

               #+allegro :lisp-path #+allegro *lisp*

	       :image-path (native-namestring img)

	       :image-path (native-namestring img)

	       :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"

	       :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"

	       :arguments '("a" "b c" "d"))

	       :arguments '("a" "b c" "d"))
@@ -74,10 +82,12 @@ 
(defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example)))

(defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example)))

(assert (absolute-pathname-p exe))

(assert (absolute-pathname-p exe))

(delete-file-if-exists exe)

(delete-file-if-exists exe)

(DBG "- first, create the standalone program")

(assert-equal

(assert-equal

 (nth-value 2

 (nth-value 2

  (run-program

  (run-program

   (symbol-call :lisp-invocation :lisp-invocation-arglist

   (symbol-call :lisp-invocation :lisp-invocation-arglist

                #+allegro :lisp-path #+allegro *lisp*

                :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))

                :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))

                :eval "(asdf-test::make-hello-program)")

                :eval "(asdf-test::make-hello-program)")

   :output t :error-output :output :input nil))

   :output t :error-output :output :input nil))
@@ -85,9 +95,11 @@ 




(assert (probe-file* exe) () "Can't find executable file ~S" exe)

(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)

(assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)

              '("hello, world"))

              '("hello, world"))





(DBG "- use that with arguments")

(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)

(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)

              '("hello, world"

              '("hello, world"

                "You passed 3 arguments:"

                "You passed 3 arguments:"

uiop/image.lisp

+1 −2
Original line number Original line Diff line number Diff line
@@ -438,8 +438,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." 
               ((:image)

               ((:image)

                (setf kind :program) ;; to ECL, it's just another program.

                (setf kind :program) ;; to ECL, it's just another program.

                `((setf *image-dumped-p* t)

                `((setf *image-dumped-p* t)

                  ;; fall through should be equivalent to: (si::top-level t) (quit)

                  (si::top-level t) (quit)))

                  ))

               ((:program)

               ((:program)

                `((setf *image-dumped-p* :executable)

                `((setf *image-dumped-p* :executable)

                  (shell-boolean-exit

                  (shell-boolean-exit