Commit d1700092 authored by Elias Pipping's avatar Elias Pipping

%process-status: Refactor

parent 27aedd56
...@@ -176,6 +176,11 @@ argument to pass to the internal RUN-PROGRAM" ...@@ -176,6 +176,11 @@ argument to pass to the internal RUN-PROGRAM"
(defun %signal-to-exit-code (signum) (defun %signal-to-exit-code (signum)
(+ 128 signum)) (+ 128 signum))
(defun %code-to-status (exit-code signal-code)
(cond ((null exit-code) :running)
((null signal-code) (values :exited exit-code))
(t (values :signaled signal-code))))
#+mkcl #+mkcl
(defun %mkcl-signal-to-number (signal) (defun %mkcl-signal-to-number (signal)
(require :mk-unix) (require :mk-unix)
...@@ -266,12 +271,10 @@ argument to pass to the internal RUN-PROGRAM" ...@@ -266,12 +271,10 @@ argument to pass to the internal RUN-PROGRAM"
(if-let (process (slot-value process-info 'process)) (if-let (process (slot-value process-info 'process))
(multiple-value-bind (status code) (multiple-value-bind (status code)
(progn (progn
#+allegro (multiple-value-bind (exit-code pid signal) #+allegro (multiple-value-bind (exit-code pid signal-code)
(sys:reap-os-subprocess :pid process :wait nil) (sys:reap-os-subprocess :pid process :wait nil)
(assert pid) (assert pid)
(cond ((null exit-code) :running) (%code-to-status exit-code signal-code))
((null signal) (values :exited exit-code))
(t (values :signaled signal))))
#+clozure (ccl:external-process-status process) #+clozure (ccl:external-process-status process)
#+(or cmucl scl) (let ((status (ext:process-status process))) #+(or cmucl scl) (let ((status (ext:process-status process)))
(values status (if (member status '(:exited :signaled)) (values status (if (member status '(:exited :signaled))
...@@ -279,14 +282,12 @@ argument to pass to the internal RUN-PROGRAM" ...@@ -279,14 +282,12 @@ argument to pass to the internal RUN-PROGRAM"
#+ecl (ext:external-process-status process) #+ecl (ext:external-process-status process)
#+lispworks #+lispworks
;; a signal is only returned on LispWorks 7+ ;; a signal is only returned on LispWorks 7+
(multiple-value-bind (exit-code signal) (multiple-value-bind (exit-code signal-code)
(symbol-call :sys (symbol-call :sys
#+lispworks7+ :pipe-exit-status #+lispworks7+ :pipe-exit-status
#-lispworks7+ :pid-exit-status #-lispworks7+ :pid-exit-status
process :wait nil) process :wait nil)
(cond ((null exit-code) :running) (%code-to-status exit-code signal-code))
((null signal) (values :exited exit-code))
(t (values :signaled signal))))
#+mkcl (let ((status (mk-ext:process-status process)) #+mkcl (let ((status (mk-ext:process-status process))
(code (mk-ext:process-exit-code process))) (code (mk-ext:process-exit-code process)))
(if (stringp code) (if (stringp code)
......
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