mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +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-error-port))
(if server-listening?
(let ((pid (primitive-fork-if-available)))
;; Spawn a server process.
(case pid
((-1) (throw 'unresolved))
((0) ;; the kid: serve two connections and exit
(let serve ((conn
(false-if-exception (accept server-socket)))
(count 1))
(if (not conn)
(exit 1)
(if (> count 0)
(serve (false-if-exception (accept server-socket))
(- count 1)))))
(exit 0))
(else ;; the parent
(set! server-pid pid)
#t))))
(when server-listening?
(let ((pid (primitive-fork-if-available)))
;; Spawn a server process.
(case pid
((-1) ;; fork not available
#f)
((0) ;; the kid: serve two connections and exit
(let serve ((conn
(false-if-exception (accept server-socket)))
(count 1))
(if (not conn)
(exit 1)
(if (> count 0)
(serve (false-if-exception (accept server-socket))
(- count 1)))))
(exit 0))
(else ;; the parent
(set! server-pid pid)
#t))))
(pass-if "connect"
(if (not server-pid)