Port to CHICKEN 6HEAD1.7.0master

This allows us to reduce the code considerably because CHICKEN 6 now
has native process objects, so we don't need to keep our own version
of process tracking.

Note that we still need to keep our own list of child processes
created by "fork", because we want the automatic subprocess reaper to
be able to work in a thread.  This means we still need to have a
central mapping of our own subprocesses to condition object so we can
signal the thread which is waiting.

After all I'm not so sure if this was such a great idea, but it's kind
of a neat feature that could be useful, so keep it for now.

6 files changed, 191 insertions, 266 deletions

diff --git a/scsh-process.egg b/scsh-process.egg
index 25b83f8..59ffcc9 100644
--- a/scsh-process.egg
+++ b/scsh-process.egg
@@ -4,8 +4,8 @@
  (author "Peter Bex")
  (category os)
  (license "BSD")
- (dependencies srfi-18 llrb-tree)
+ (dependencies srfi-18 srfi-69)
  (test-dependencies test)
  (components
   (extension scsh-process
-             (csc-options "-O3" "-feature" "has-thread-killer"))))
+             (csc-options "-O3"))))
diff --git a/scsh-process.meta b/scsh-process.meta
deleted file mode 100644
index 1dbb1be..0000000
--- a/scsh-process.meta
+++ /dev/null
@@ -1,8 +0,0 @@
-;;; scsh-process.meta -*- Scheme -*-
-
-((synopsis "A reimplementation for CHICKEN of SCSH's process notation.")
- (author "Peter Bex")
- (category os)
- (license "BSD")
- (depends llrb-tree)
- (test-depends test))
diff --git a/scsh-process.release-info b/scsh-process.release-info
index ef9f9ed..24cf402 100644
--- a/scsh-process.release-info
+++ b/scsh-process.release-info
@@ -1,31 +1,3 @@
 (repo git "https://code.more-magic.net/{egg-name}")
 (uri targz "https://code.more-magic.net/{egg-name}/snapshot/{egg-name}-{egg-release}.tar.gz")
-(release "0.1")
-(release "0.1.1")
-(release "0.1.2")
-(release "0.2")
-(release "0.2.1")
-(release "0.3")
-(release "0.3.1")
-(release "0.4")
-(release "0.4.1")
-(release "0.5")
-(release "0.6")
-(release "0.7")
-(release "0.7.1")
-(release "0.8")
-(release "0.8.1")
-(release "0.8.2")
-(release "0.8.3")
-(release "0.9.0")
-(release "1.0.0")
-(release "1.1.0")
-(release "1.2.0")
-(release "1.2.1")
-(release "1.2.2")
-(release "1.3.0")
-(release "1.4.0")
-(release "1.5.0")
-(release "1.5.1")
-(release "1.5.2")
-(release "1.6.0")
+(release "1.7.0")
diff --git a/scsh-process.release-info.chicken-5 b/scsh-process.release-info.chicken-5
deleted file mode 100644
index 62a173d..0000000
--- a/scsh-process.release-info.chicken-5
+++ /dev/null
@@ -1,7 +0,0 @@
-(repo git "https://code.more-magic.net/{egg-name}")
-(uri targz "https://code.more-magic.net/{egg-name}/snapshot/{egg-name}-{egg-release}.tar.gz")
-(release "1.4.0")
-(release "1.5.0")
-(release "1.5.1")
-(release "1.5.2")
-(release "1.6.0")
diff --git a/scsh-process.scm b/scsh-process.scm
index af3586e..bcc6dbd 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -8,34 +8,31 @@
 ;;
 ;; || wasn't changed, but it's really the zero-length symbol
 ;;
-;; WARNING: Don't mix with threading unless you're using
-;;          Chicken 4.8.1 rev 47b5be71 or later.
+;;; Copyright (c) 2012-2025, Peter Bex
+;;; All rights reserved.
 ;;
-;;; Copyright (c) 2012-2021, Peter Bex
-;; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
-; modification, are permitted provided that the following conditions
-; are met:
-;
-; 1. Redistributions of source code must retain the above copyright
-;    notice, this list of conditions and the following disclaimer.
-; 2. Redistributions in binary form must reproduce the above copyright
-;    notice, this list of conditions and the following disclaimer in the
-;    documentation and/or other materials provided with the distribution.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
-; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-; OF THE POSSIBILITY OF SUCH DAMAGE.
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in the
+;;    documentation and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+;; OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (declare
   ;; Avoid FD leaks due to context switch between create-pipe and fork
@@ -50,20 +47,15 @@
    run/collecting run/string run/strings run/port run/file run/sexp run/sexps
    || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string)
 
-   process? proc:pid proc? wait signal-process process-sleep)
+   proc:pid proc? wait signal-process process-sleep)
 
 (import scheme)
 
-(cond-expand
-  (chicken-5 (import (chicken base) (chicken condition) (chicken io)
-                     (chicken port) (chicken file) (chicken file posix)
-                     (chicken fixnum) (chicken string) (chicken process)
-                     (chicken bitwise) (chicken process signal)
-                     srfi-18 llrb-fixnum-table))
-  (else (import chicken)
-        (use data-structures (rename extras (read-file read-list))
-             utils files ports posix srfi-1 srfi-18)
-        (use llrb-fixnum-table)))
+(import (chicken base) (chicken condition) (chicken io)
+        (chicken port) (chicken file) (chicken file posix)
+        (chicken fixnum) (chicken string) (chicken process)
+        (chicken bitwise) (chicken process signal)
+        srfi-18 srfi-69)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Process bookkeeping ;;
@@ -73,15 +65,18 @@
 ;; processes without having to wait for all of them in user code.  We
 ;; need to keep a hash table around so that the user can still wait
 ;; for his own processes without the signal/chld handler interfering
-;; with those.  It's a bit of hack the way we overwrite the regular
-;; process-wait procedure from POSIX, but this allows us to
-;; transparently mark off processes which were waited on by the user.
-
-(define-record scsh-process pid exit-status ok? child-condition)
-
-;; Aaaand another hack to avoid getting "deadlock detected" when all
-;; threads are waiting for a child condition.  We can still get woken
-;; up by the signal/chld handler (see below).
+;; with those.
+;; Now that process-wait from POSIX directly supports process objects,
+;; we use those, but we still install a handler to allow waiting for
+;; processes "in the background".  This is because that will make this
+;; egg (like scsh itself) easier to use as a shell replacement
+;; without having to worry about zombie processes.  To make that
+;; work properly, we keep track of all processes started by this egg
+;; in a global table.
+
+;; A hack to avoid getting "deadlock detected" when all threads are
+;; waiting for a child condition.  We can still get woken up by the
+;; signal/chld handler (see below).
 (define (install-deadlock-workaround!)
   (thread-start!
    (make-thread (lambda () (let lp () (thread-sleep! 100) (lp)))
@@ -89,146 +84,135 @@
 
 (install-deadlock-workaround!) ;; And again on fork
 
-(define proc:pid scsh-process-pid)
-(define proc? scsh-process?)
-
-;; Deprecated
-(define process? scsh-process?)
+(define proc:pid process-id)
+(define proc? process?)
 
-(define *scsh-pending-processes* (make-table))
+(define *scsh-pending-processes* (make-hash-table))
 
 (define (clear-scsh-pending-processes!)
-  (set! *scsh-pending-processes* (make-table)))
+  (set! *scsh-pending-processes* (make-hash-table)))
 
-(define (add-scsh-pending-process! pid)
-  (let* ((c (make-condition-variable pid))
-         (process (make-scsh-process pid #f #f c)))
-    (table-update! *scsh-pending-processes* pid (lambda (x) process) (lambda () #f))
+(define (add-scsh-pending-process! process)
+  (let* ((pid (process-id process))
+         (condition (make-condition-variable (conc "process(" pid ")"))))
+    (hash-table-update! *scsh-pending-processes* pid (lambda (x) (cons process condition)) (lambda () #f))
     process))
 
 (define (scsh-pending-process-ref/default pid default)
-  (table-ref/default *scsh-pending-processes* pid default))
+  (hash-table-ref/default *scsh-pending-processes* pid default))
 
 (define (remove-scsh-pending-process! pid)
-  (table-delete! *scsh-pending-processes* pid))
+  (hash-table-delete! *scsh-pending-processes* pid))
 
 (define (scsh-pending-process-fold proc nil)
-  (table-fold *scsh-pending-processes* proc nil))
+  (hash-table-fold *scsh-pending-processes* proc nil))
 
 (define (snapshot-scsh-pending-process)
-  (let ((copy (table-copy *scsh-pending-processes*)))
-    (lambda (pid) (table-ref/default copy pid #f))))
+  (let ((copy (hash-table-copy *scsh-pending-processes*)))
+    (lambda (pid) (hash-table-ref/default copy pid #f))))
 
 (define wait #f)
 
-(let ((posix-process-wait process-wait))
-  (set! process-wait
-        (lambda (#!optional pid nohang)
-          (receive (status ok? pid) (wait pid nohang) (values pid ok? status))))
-
-  (set! wait
-        (lambda (#!optional pid-or-process nohang)
-          (unless (or (not pid-or-process)
-                      (scsh-process? pid-or-process)
-                      (number? pid-or-process))
-            (error 'process-wait
-                   "Not a scsh-type process object or pid"
-                   pid-or-process))
-          ;; We need to make a copy when waiting for #f, because we
-          ;; can't predict which pid we'll receive, and the SIGCHLD
-          ;; handler will drop the pid from the pending list.
-          (let ((pending-before
-                 (if pid-or-process
-                     #f
-                     (snapshot-scsh-pending-process)))
-                (p (if (and pid-or-process (number? pid-or-process))
-                       (scsh-pending-process-ref/default pid-or-process #f)
-                       pid-or-process)))
-            (if (and p (scsh-process-exit-status p))
-                (values (scsh-process-exit-status p)
-                        (scsh-process-ok? p)
-                        (scsh-process-pid p))
-		(handle-exceptions exn
-                    (if (and p (scsh-process-exit-status p)) ; Signal might've occurred
-                        (values (scsh-process-exit-status p)
-                                (scsh-process-ok? p)
-                                (scsh-process-pid p))
-                        (abort exn))
-                  (let lp ()
-                    (receive (pid ok? status)
-                        (posix-process-wait
-                         (if p (scsh-process-pid p) pid-or-process)
-                         ;; When we have p, "nohang" is ignored because
-                         ;; the thread will hang on the condition var
-                         ;; rather than letting the entire process hang.
-                         (if p #t nohang))
-                      (cond
-                       ((zero? pid)
-                        (if nohang
-                            (values #f #f #f)
-                            (let ((m (make-mutex)))
-                              (mutex-unlock! m (scsh-process-child-condition p))
-                              (if (not (scsh-process-exit-status p))
-                                  (lp)  ; could be forcibly unblocked
-                                  (values (scsh-process-exit-status p)
-                                          (scsh-process-ok? p)
-                                          (scsh-process-pid p))))))
-                       (else
-                        (and-let* ((p (or p (pending-before pid))))
-                          (scsh-process-exit-status-set! p status)
-                          (scsh-process-ok?-set! p ok?)
-                          (condition-variable-broadcast!
-                           (scsh-process-child-condition p)))
-
-                        (remove-scsh-pending-process! pid)
-                        (values status ok? pid))))))))))
-
-  (set-signal-handler!
-   signal/chld
-   ;; This workaround fixes the "signal-hander" type in the types.db of 4.8.0
-   (let-syntax ((workaround
-                 (cond-expand
-                  (chicken-4.8
-                   (syntax-rules ()
-                     ((_ val) (the (or boolean (procedure (fixnum) . *)) val))))
-                  (else (syntax-rules () ((_ val) val))))))
-     (let* ((old-handler (workaround (signal-handler signal/chld)))
-            (rst #f) ;; restart scan if true
-            (handler
-             ;; Run the signal handler in another thread. This is needed
-             ;; because the current thread may be waiting on a condition
-             ;; variable, and we can't wake ourselves up.
-             (thread-start!
-              (lambda ()
-                (do () (#f)
-                  (set! rst #f)
-                  (scsh-pending-process-fold
-                   (lambda (pid p i)
-                     (and
-                      p
-                      (not (scsh-process-exit-status p))
-                      (receive (pid ok? status)
-                               (posix-process-wait pid #t)
-                               (if (and (not (zero? pid)) p)
-                                   (begin
-                                     (scsh-process-exit-status-set! p status)
-                                     (scsh-process-ok?-set! p ok?)
-                                     (condition-variable-broadcast!
-                                      (scsh-process-child-condition p))
-                                     ;; The GC can clean it up
-                                     (remove-scsh-pending-process! pid))))))
-                   #f)
-                  (unless rst (thread-suspend! (current-thread))))))
-             ))
-       (lambda (signal)
-         (set! rst #t)
-         (thread-resume! handler)
-         (when old-handler (old-handler signal)))))))
-
-(define (signal-process proc sig)
-  (process-signal (scsh-process-pid proc) sig))
-
-(define process-sleep sleep)
+(define (wait #!optional pid-or-process nohang)
+  (unless (or (not pid-or-process)
+              (process? pid-or-process)
+              (number? pid-or-process))
+    (error 'process-wait
+           "Not a process object or pid"
+           pid-or-process))
+  ;; We need to make a copy when waiting for #f, because we
+  ;; can't predict which pid we'll receive, and the SIGCHLD
+  ;; handler will drop the pid from the pending list.
+  (let ((pending-before
+         (if pid-or-process
+             #f
+             (snapshot-scsh-pending-process))))
+    (handle-exceptions exn
+        ;; Signal might've occurred, our sigchld handler may have waited already
+        ;; which would cause an error here.  Assume that this means the process
+        ;; exit information has been populated and that if that is the case,
+        ;; that is the only error that can occur.
+        (if (and (process? pid-or-process)
+                 (process-exit-status pid-or-process))
+            (values (process-exit-status pid-or-process)
+                    (process-returned-normally? pid-or-process)
+                    (process-id pid-or-process))
+            (abort exn))
+        (let lp ()
+          (receive (pid ok? status)
+              (process-wait
+               pid-or-process
+               ;; When we have pid-or-process, "nohang" is ignored
+               ;; because the thread will hang on the condition var
+               ;; rather than letting the entire process hang.
+               (if pid-or-process #t nohang))
+            (cond
+             ((zero? pid)
+              (if nohang
+                  (values #f #f #f)
+                  (let* ((m (make-mutex))
+                         (proc+condition (and pending-before
+                                              (pending-before (if (number? pid-or-process)
+                                                                  pid-or-process
+                                                                  (process-id pid-or-process)))))
+                         (proc (if (process? pid-or-process)
+                                   pid-or-process
+                                   (car proc+condition))))
+                    (when proc+condition
+                      (mutex-unlock! m (cdr proc+condition)))
+                    (if (or (number? pid-or-process)
+                            (not (process-exit-status proc)))
+                        (lp)            ; could be forcibly unblocked
+                        (begin
+                          (remove-scsh-pending-process! pid)
+                          (values (process-exit-status proc)
+                                  (process-returned-normally? proc)
+                                  (process-id proc)))))))
+             (else
+              (and-let* (pending-before
+                         pid-or-process
+                         (proc+condition (pending-before (if (number? pid-or-process)
+                                                             pid-or-process
+                                                             (process-id pid-or-process)))))
+                (condition-variable-broadcast!
+                 (cdr proc+condition)))
+
+              (remove-scsh-pending-process! pid)
+              (values status ok? pid))))))))
+
+(set-signal-handler!
+ signal/chld
+ (let* ((old-handler (signal-handler signal/chld))
+        (rst #f) ;; restart scan if true
+        (handler
+         ;; Run the signal handler in another thread. This is needed
+         ;; because the current thread may be waiting on a condition
+         ;; variable, and we can't wake ourselves up.
+         (thread-start!
+          (lambda ()
+            (do () (#f)
+              (set! rst #f)
+              (scsh-pending-process-fold
+               (lambda (pid proc+condition i)
+                 (and
+                  proc+condition
+                  (not (process-exit-status (car proc+condition)))
+                  (not (zero? pid))
+                  (receive (pid ok? status)
+                      (process-wait (car proc+condition) #t)
+                    (unless (zero? pid)
+                      (condition-variable-broadcast!
+                       (cdr proc+condition))
+                      (remove-scsh-pending-process! pid)))))
+               #f)
+              (unless rst (thread-suspend! (current-thread))))))
+         ))
+   (lambda (signal)
+     (set! rst #t)
+     (thread-resume! handler)
+     (when old-handler (old-handler signal)))))
+
+(define signal-process process-signal)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Execution and forking helpers ;;
@@ -271,26 +255,20 @@
         (lambda ()
           (let* ((maybe-reinstall-deadlock-workaround!
                   (lambda ()
-                    (cond-expand
-                      (has-thread-killer
-                       (unless continue-threads? (install-deadlock-workaround!)))
-                      (else (void)))))
+                    (unless continue-threads? (install-deadlock-workaround!))))
                  (thunk (and thunk (lambda ()
                                      (clear-scsh-pending-processes!)
                                      (maybe-reinstall-deadlock-workaround!)
                                      (unless sigchld-was-masked?
                                        (signal-unmask! signal/chld))
                                      (thunk))))
-                 (pid (cond-expand
-                        (has-thread-killer
-                         (process-fork thunk (not continue-threads?)))
-                        (else ;; Ignore both args if thunk is #f, so #f won't be applied
-                         (if thunk (process-fork thunk) (process-fork))))))
-            (cond ((zero? pid)
-                   (clear-scsh-pending-processes!)
-                   (maybe-reinstall-deadlock-workaround!)
-                   #f)
-                  (else (add-scsh-pending-process! pid)))))
+                 (process (process-fork thunk (not continue-threads?))))
+            (if process
+                (add-scsh-pending-process! process)
+                (begin
+                  (clear-scsh-pending-processes!)
+                  (maybe-reinstall-deadlock-workaround!)
+                  #f))))
         (lambda ()
           (unless sigchld-was-masked? (signal-unmask! signal/chld))))))
 
diff --git a/tests/run.scm b/tests/run.scm
index b5fa419..85a6b11 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,27 +1,18 @@
+;;(include "../scsh-process.scm")
 (module scsh-tests ()
 
-(import scheme)
-
-(cond-expand
-  (chicken-5 (import (chicken base) (chicken port) (chicken condition)
-                     (chicken io) (chicken file) (chicken file posix)
-                     (chicken process signal)
-                     (chicken fixnum) ;; Why is this needed?!
-                     srfi-18 test)
-             #;(include "../scsh-process.scm")
-             (import scsh-process)
-
-             (define (read-all #!optional file-or-port)
-               (cond ((string? file-or-port)
-                      (with-input-from-file file-or-port read-string))
-                     (file-or-port (read-string #f file-or-port))
-                     (else (read-string))))
-             )
-  (else (import chicken)
-        #;(include "../scsh-process.scm")
-        (use scsh-process)
-        (use test utils extras ports files posix
-             srfi-13 srfi-18 (only setup-api version>=?))))
+(import (scheme base) (scheme write) (scheme read)
+        (chicken base) (chicken port) (chicken condition)
+        (chicken io) (chicken file) (chicken file posix)
+        (chicken process signal)
+        srfi-18 test)
+(import scsh-process)
+
+(define (read-all #!optional file-or-port)
+  (cond ((string? file-or-port)
+         (with-input-from-file file-or-port read-string))
+        (file-or-port (read-string #f file-or-port))
+        (else (read-string))))
 
 (test-begin "scsh-process")
 
@@ -149,19 +140,16 @@
     (test "run/string with begin form"
           "hi, there\n"
           (run/string (pipe (begin (print "hi, there")) (cat))))
-    (when (cond-expand
-            (chicken-5 #t)
-            (else (version>=? (chicken-version) "4.8.1")))
-      (let ((child? #f))
-        (thread-start! (lambda ()
-                         (thread-sleep! 0.5)
-                         (when child? (print "haihai"))))
-        (test "Simple 'begin' form with threading"
-              "hi, there\n"
-              (run/string (pipe (begin (set! child? #t)
-                                       (thread-sleep! 1)
-                                       (print "hi, there"))
-                                (cat))))))
+    (let ((child? #f))
+      (thread-start! (lambda ()
+                       (thread-sleep! 0.5)
+                       (when child? (print "haihai"))))
+      (test "Simple 'begin' form with threading"
+            "hi, there\n"
+            (run/string (pipe (begin (set! child? #t)
+                                     (thread-sleep! 1)
+                                     (print "hi, there"))
+                              (cat)))))
     
     (let ((the-outfile "outfile"))
       (test "Subprocess writing to a file"
@@ -245,6 +233,8 @@
           (|| (false) (epf (sh -c "echo hi && false") (- 1))))))
 
 (test-group "finalization"
+  ;; Ensure the automatic reaping thread has a chance to run
+  (thread-yield!)
   ;; TODO: Find a way to test that the input port didn't get replaced by
   ;;       one from a subshell.  This happened before, but not sure how
   ;;       to detect this except running it manually from the REPL.