From 1e47e4e33a406a3a2d5b08cba7f92625a398a52b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Elias=20M=C3=A5rtenson?= Date: Mon, 3 Sep 2012 23:33:42 +0800 Subject: [PATCH 1/7] Added the function TRIVIAL-SHELL:EXIT --- dev/allegro.lisp | 2 ++ dev/clisp.lisp | 3 +++ dev/cmucl.lisp | 5 ++++- dev/digitool.lisp | 3 +++ dev/ecl.lisp | 5 ++++- dev/lispworks.lisp | 5 ++++- dev/openmcl.lisp | 5 ++++- dev/package.lisp | 1 + dev/sbcl.lisp | 5 ++++- dev/shell.lisp | 9 +++++++++ 10 files changed, 38 insertions(+), 5 deletions(-) diff --git a/dev/allegro.lisp b/dev/allegro.lisp index 60976d0..1234d77 100644 --- a/dev/allegro.lisp +++ b/dev/allegro.lisp @@ -32,3 +32,5 @@ (defun %get-env-var (name) (sys:getenv name)) +(defun %exit (code) + (excl:exit code)) diff --git a/dev/clisp.lisp b/dev/clisp.lisp index 3008950..9ada5d5 100644 --- a/dev/clisp.lisp +++ b/dev/clisp.lisp @@ -14,3 +14,6 @@ (defun %get-env-var (name) (ext:getenv name)) + +(defun %exit (code) + (ext:exit code)) diff --git a/dev/cmucl.lisp b/dev/cmucl.lisp index f23f189..c59228f 100644 --- a/dev/cmucl.lisp +++ b/dev/cmucl.lisp @@ -21,4 +21,7 @@ (defun %get-env-var (name) (cdr (assoc (intern (substitute #\_ #\- name) :keyword) - ext:*environment-list*))) \ No newline at end of file + ext:*environment-list*))) + +(defun %exit (code) + (ext:quit code)) diff --git a/dev/digitool.lisp b/dev/digitool.lisp index 923122c..1ab9d98 100644 --- a/dev/digitool.lisp +++ b/dev/digitool.lisp @@ -4,3 +4,6 @@ (when input (error "This version of trivial-shell does not support the input parameter.")) (ccl:do-shell-script command)) + +(defun %exit (code) + (error 'unsupported-function-error :function 'exit)) diff --git a/dev/ecl.lisp b/dev/ecl.lisp index 201a501..49bf984 100644 --- a/dev/ecl.lisp +++ b/dev/ecl.lisp @@ -7,4 +7,7 @@ (error 'unsupported-function-error :function 'os-process-id)) (defun %get-env-var (name) - (ext:getenv name)) \ No newline at end of file + (ext:getenv name)) + +(defun %exit (code) + (ext:exit code)) diff --git a/dev/lispworks.lisp b/dev/lispworks.lisp index 21395bc..40d80e3 100644 --- a/dev/lispworks.lisp +++ b/dev/lispworks.lisp @@ -19,4 +19,7 @@ (error 'unsupported-function-error :function 'os-process-id)) (defun %get-env-var (name) - (lw:environment-variable name)) \ No newline at end of file + (lw:environment-variable name)) + +(defun %exit (code) + (lw:quit :status code)) diff --git a/dev/openmcl.lisp b/dev/openmcl.lisp index c2d7411..ec6a8fb 100644 --- a/dev/openmcl.lisp +++ b/dev/openmcl.lisp @@ -30,4 +30,7 @@ (error 'unsupported-function-error :function 'os-process-id)) (defun %get-env-var (name) - (ccl::getenv name)) \ No newline at end of file + (ccl::getenv name)) + +(defun %exit (code) + (ccl:quit code)) diff --git a/dev/package.lisp b/dev/package.lisp index df38d28..f5baba6 100644 --- a/dev/package.lisp +++ b/dev/package.lisp @@ -7,6 +7,7 @@ #:shell-command #:with-timeout #:get-env-var + #:exit #:*bourne-compatible-shell* #:*shell-search-paths* diff --git a/dev/sbcl.lisp b/dev/sbcl.lisp index 4ccc5fa..51b1eff 100644 --- a/dev/sbcl.lisp +++ b/dev/sbcl.lisp @@ -84,4 +84,7 @@ (error 'unsupported-function-error :function 'os-process-id)) (defun %get-env-var (name) - (sb-ext:posix-getenv name)) \ No newline at end of file + (sb-ext:posix-getenv name)) + +(defun %exit (code) + (sb-ext:exit :code code)) diff --git a/dev/shell.lisp b/dev/shell.lisp index 32c603c..d126bb8 100644 --- a/dev/shell.lisp +++ b/dev/shell.lisp @@ -69,3 +69,12 @@ may be used to find a shell to use in executing `command`." (defun get-env-var (name) "Return the value of the environment variable `name`." (%get-env-var name)) + +(defun exit (&optional (code :success)) + "Exit the process. CODE is either a numeric exit code, or the special values :SUCCESS +or :FAILURE, which maps to the appropriate exit codes for the operating system." + ;; Currently, :SUCCESS always maps to 0 and :FAILURE maps to 1 + (%exit (cond ((eq code :success) 0) + ((eq code :failure) 1) + ((integerp code) code) + (t (error "Illegal exit code: ~s (should be an integer or the values :SUCCESS or :FAILURE)" code))))) From 13f132e6223816d3f0012ff0afdda59837669b1a Mon Sep 17 00:00:00 2001 From: Elias Martenson Date: Tue, 4 Sep 2012 09:13:00 +0800 Subject: [PATCH 2/7] CMUCL does not support exit codes. Thus, an error is raised if the given code is non-zero. --- dev/cmucl.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/dev/cmucl.lisp b/dev/cmucl.lisp index c59228f..5821c05 100644 --- a/dev/cmucl.lisp +++ b/dev/cmucl.lisp @@ -24,4 +24,6 @@ ext:*environment-list*))) (defun %exit (code) - (ext:quit code)) + (unless (zerop code) + (error "CMUCL does not support exit codes.")) + (ext:quit)) From 04870161c4130a1d971e99ee5bd0d46526e7d551 Mon Sep 17 00:00:00 2001 From: Elias Martenson Date: Tue, 4 Sep 2012 09:36:54 +0800 Subject: [PATCH 3/7] Older versions of SBCL had a function SB-EXT:QUIT instead of SB-EXT:EXIT. This fix checks whether SB-EXT:EXIT exists, and if not, will fall back to the older way of doing it. --- dev/sbcl.lisp | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/dev/sbcl.lisp b/dev/sbcl.lisp index 51b1eff..00127fc 100644 --- a/dev/sbcl.lisp +++ b/dev/sbcl.lisp @@ -86,5 +86,16 @@ (defun %get-env-var (name) (sb-ext:posix-getenv name)) +(defun symbol-if-external (name package) + (multiple-value-bind (symbol s) (find-symbol name package) + (when (eq s :external) + symbol))) + (defun %exit (code) - (sb-ext:exit :code code)) + (let ((exit-sym (symbol-if-external "EXIT" "SB-EXT"))) + (if exit-sym + (funcall exit-sym :code code) + (let ((quit-sym (symbol-if-external "QUIT" "SB-EXT"))) + (if quit-sym + (funcall quit-sym :code code :recklessly-p t) + (error "SBCL version without EXIT or QUIT.")))))) From 7a0ad09a52b0a90e9795e256075e7faf711d97a5 Mon Sep 17 00:00:00 2001 From: Elias Martenson Date: Tue, 4 Sep 2012 09:58:46 +0800 Subject: [PATCH 4/7] Old SB-EXT:QUIT does not support an exit code. In the fallback code for older versions of SBCL, removed the exit code argument and replaced it with a check that verifies that the requested code is zero. --- dev/sbcl.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/dev/sbcl.lisp b/dev/sbcl.lisp index 00127fc..dbbca3b 100644 --- a/dev/sbcl.lisp +++ b/dev/sbcl.lisp @@ -97,5 +97,7 @@ (funcall exit-sym :code code) (let ((quit-sym (symbol-if-external "QUIT" "SB-EXT"))) (if quit-sym - (funcall quit-sym :code code :recklessly-p t) + (if (zerop code) + (funcall quit-sym :recklessly-p t) + (error "This version of SBCL does not support exiting with a code.")) (error "SBCL version without EXIT or QUIT.")))))) From 4c0e7674bdf65154fe26f44e87fbd21c459b3b50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Elias=20M=C3=A5rtenson?= Date: Tue, 4 Sep 2012 22:28:21 +0800 Subject: [PATCH 5/7] Add implementation of EXIT for SCL. --- dev/scl.lisp | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/dev/scl.lisp b/dev/scl.lisp index 360828a..1583357 100644 --- a/dev/scl.lisp +++ b/dev/scl.lisp @@ -7,4 +7,7 @@ (error 'unsupported-function-error :function 'os-process-id)) (defun %get-env-var (name) - (cdr (assoc name ext:*environment-list* :test #'string=)) \ No newline at end of file + (cdr (assoc name ext:*environment-list* :test #'string=)) + +(defun %exit (code) + (ext:quit :status code)) From da7d45b14083041c6540d5ba3708e73a142ca76e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Elias=20M=C3=A5rtenson?= Date: Tue, 4 Sep 2012 22:40:07 +0800 Subject: [PATCH 6/7] Force reckless quit on CMUCL --- dev/cmucl.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/cmucl.lisp b/dev/cmucl.lisp index 5821c05..3a6c57f 100644 --- a/dev/cmucl.lisp +++ b/dev/cmucl.lisp @@ -26,4 +26,4 @@ (defun %exit (code) (unless (zerop code) (error "CMUCL does not support exit codes.")) - (ext:quit)) + (ext:quit t)) From f442762c483a28d4f230265b57a8c1cf61c89431 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Elias=20M=C3=A5rtenson?= Date: Tue, 4 Sep 2012 22:41:43 +0800 Subject: [PATCH 7/7] The old-style QUIT of SBCL actually supports exit status. Update the code to comply with this. --- dev/sbcl.lisp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/dev/sbcl.lisp b/dev/sbcl.lisp index dbbca3b..21bcc22 100644 --- a/dev/sbcl.lisp +++ b/dev/sbcl.lisp @@ -97,7 +97,5 @@ (funcall exit-sym :code code) (let ((quit-sym (symbol-if-external "QUIT" "SB-EXT"))) (if quit-sym - (if (zerop code) - (funcall quit-sym :recklessly-p t) - (error "This version of SBCL does not support exiting with a code.")) + (funcall quit-sym :unix-status code :recklessly-p t) (error "SBCL version without EXIT or QUIT."))))))