mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

socket test should not throw unresolved outside of a test

Browse source 
* test-suite/tests/00-socket.test: don't throw unresolved outside of a
    test
This commit is contained in:
Michael Gran 2020-12-30 06:00:35 -08:00
parent c65154ac69
commit 91d4d31184
1 changed files with 19 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

37
test-suite/tests/00-socket.test
View file

@ -264,24 +264,25 @@
(force-output (current-output-port)) (force-output (current-output-port))
(force-output (current-error-port)) (force-output (current-error-port))
(if server-listening? (when server-listening?
(let ((pid (primitive-fork-if-available))) (let ((pid (primitive-fork-if-available)))
;; Spawn a server process. ;; Spawn a server process.
(case pid (case pid
((-1) (throw 'unresolved)) ((-1) ;; fork not available
((0) ;; the kid: serve two connections and exit #f)
(let serve ((conn ((0) ;; the kid: serve two connections and exit
(false-if-exception (accept server-socket))) (let serve ((conn
(count 1)) (false-if-exception (accept server-socket)))
(if (not conn) (count 1))
(exit 1) (if (not conn)
(if (> count 0) (exit 1)
(serve (false-if-exception (accept server-socket)) (if (> count 0)
(- count 1))))) (serve (false-if-exception (accept server-socket))
(exit 0)) (- count 1)))))
(else ;; the parent (exit 0))
(set! server-pid pid) (else ;; the parent
#t)))) (set! server-pid pid)
#t))))
(pass-if "connect" (pass-if "connect"
(if (not server-pid) (if (not server-pid)