Skip to content
Snippets Groups Projects
Commit 8dd8b1ea authored by Elias Pipping's avatar Elias Pipping
Browse files

Bug fix: Exit code with LispWorks 7

By having :process always be a stream on LispWorks 7, we make sure
that the process can be killed, have its vital signs checked, and its
PID obtained. In a simple and consistent manner.

With LispWorks 7, pid-exit-status is no longer available. We need a
stream to obtain the exit status. With save-exit-status, we can be
sure that we're given one.
parent 883bf280
No related branches found
No related tags found
No related merge requests found
...@@ -549,22 +549,31 @@ It returns a process-info object." ...@@ -549,22 +549,31 @@ It returns a process-info object."
(if wait (if wait
(prop 'exit-code (first process*)) (prop 'exit-code (first process*))
(let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
(if (zerop mode) (if (or (plusp mode) (eq error-output :stream))
(prop 'process (first process*)) (destructuring-bind (io err pid) process*
(destructuring-bind (x err pid) process* #+lispworks7+ (declare (ignore pid))
(prop 'process pid) (prop 'process #+lispworks7+ io #-lispworks7+ pid)
(prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) x) (when (plusp mode)
(when (eq error-output :stream) (prop 'error-stream err)))))) (prop (ecase mode
(1 'input-stream)
(2 'output-stream)
(3 'bidir-stream)) io))
(when (eq error-output :stream)
(prop 'error-stream err)))
;; lispworks6 returns (pid), lispworks7 returns (io,err,pid).
(prop 'process (first process*)))))
process-info))) process-info)))
(defun %process-info-pid (process-info) (defun %process-info-pid (process-info)
(let ((process (slot-value process-info 'process))) (let ((process (slot-value process-info 'process)))
(declare (ignorable process)) (declare (ignorable process))
#+(or allegro lispworks) process #+allegro process
#+clasp (si:external-process-pid process) #+clasp (si:external-process-pid process)
#+clozure (ccl:external-process-id process) #+clozure (ccl:external-process-id process)
#+ecl (ext:external-process-pid process) #+ecl (ext:external-process-pid process)
#+(or cmucl scl) (ext:process-pid process) #+(or cmucl scl) (ext:process-pid process)
#+lispworks7+ (sys:pipe-pid process)
#+(and lispworks (not lispworks7+)) process
#+mkcl (mkcl:process-id process) #+mkcl (mkcl:process-id process)
#+sbcl (sb-ext:process-pid process) #+sbcl (sb-ext:process-pid process)
#-(or allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl) #-(or allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl)
...@@ -586,14 +595,9 @@ It returns a process-info object." ...@@ -586,14 +595,9 @@ It returns a process-info object."
#+clozure (nth-value 1 (ccl:external-process-status process)) #+clozure (nth-value 1 (ccl:external-process-status process))
#+(or cmucl scl) (ext:process-exit-code process) #+(or cmucl scl) (ext:process-exit-code process)
#+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t)) #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t))
#+lispworks #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status
(if-let ((stream (or (slot-value process-info 'input-stream) #-lispworks7+ #'sys:pid-exit-status
(slot-value process-info 'output-stream) process :wait t)
(slot-value process-info 'bidir-stream)
(slot-value process-info 'error-stream))))
(system:pipe-exit-status stream :wait t)
(if-let ((f (find-symbol* :pid-exit-status :system nil)))
(funcall f process :wait t)))
#+mkcl (mkcl:join-process process) #+mkcl (mkcl:join-process process)
#+sbcl (sb-ext:process-exit-code process) #+sbcl (sb-ext:process-exit-code process)
#-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl) #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment