Merge pull request #5 from lokedhs/master

Add the function TRIVIAL-SHELL:EXIT

dev/allegro.lisp

@@ -32,3 +32,5 @@
 (defun %get-env-var (name)
   (sys:getenv name))
 
+(defun %exit (code)
+  (excl:exit code))

dev/clisp.lisp

@@ -14,3 +14,6 @@
 
 (defun %get-env-var (name)
   (ext:getenv name))
+
+(defun %exit (code)
+  (ext:exit code))

dev/cmucl.lisp

@@ -21,4 +21,9 @@
 (defun %get-env-var (name)
   (cdr (assoc (intern (substitute #\_ #\- name)
 		      :keyword)
-	      ext:*environment-list*)))
+	      ext:*environment-list*)))
+
+(defun %exit (code)
+  (unless (zerop code)
+    (error "CMUCL does not support exit codes."))
+  (ext:quit t))

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

dev/ecl.lisp

@@ -7,4 +7,7 @@
   (error 'unsupported-function-error :function 'os-process-id))
 
 (defun %get-env-var (name)
-  (ext:getenv name))
+  (ext:getenv name))
+
+(defun %exit (code)
+  (ext:exit code))

dev/lispworks.lisp

@@ -19,4 +19,7 @@
   (error 'unsupported-function-error :function 'os-process-id))
 
 (defun %get-env-var (name)
-  (lw:environment-variable name))
+  (lw:environment-variable name))
+
+(defun %exit (code)
+  (lw:quit :status code))

dev/openmcl.lisp

@@ -30,4 +30,7 @@
   (error 'unsupported-function-error :function 'os-process-id))
 
 (defun %get-env-var (name)
-  (ccl::getenv name))
+  (ccl::getenv name))
+
+(defun %exit (code)
+  (ccl:quit code))

dev/package.lisp

@@ -7,6 +7,7 @@
    #:shell-command
    #:with-timeout
    #:get-env-var
+   #:exit
    #:*bourne-compatible-shell*
    #:*shell-search-paths*
 

dev/sbcl.lisp

@@ -84,4 +84,18 @@
   (error 'unsupported-function-error :function 'os-process-id))
 
 (defun %get-env-var (name)
-  (sb-ext:posix-getenv 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)
+  (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 :unix-status code :recklessly-p t)
+              (error "SBCL version without EXIT or QUIT."))))))

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=))
+  (cdr (assoc name ext:*environment-list* :test #'string=))
+
+(defun %exit (code)
+  (ext:quit :status code))

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