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
...@@ -492,16 +492,16 @@ itself.")) ;; operation on a system and its dependencies ...@@ -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 ()
......
;;; -*- 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 @@ ...@@ -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 @@ ...@@ -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 @@ ...@@ -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 @@ ...@@ -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:"
......
...@@ -438,8 +438,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment