rlb pushed a commit to branch main
in repository guile.
commit 50125817455f466970bbd803a0c51fa9be0d8ba3
Author: Rob Browning <r...@defaultvalue.org>
AuthorDate: Sun Mar 2 13:51:17 2025 -0600
r6rs-ports.test: don't race with gc close in custom port tests
The tests share a "log" for custom port events and didn't always
explicitly close the test ports, so the close might come later, during
another test. Change the tests to always close their ports immediately,
and clear the log after checking for expected "inter-test" events.
test-suite/tests/r6rs-ports.test: don't race with gc close in custom
port tests.
---
NEWS | 3 ++
test-suite/tests/r6rs-ports.test | 77 +++++++++++++++++++++++-----------------
2 files changed, 48 insertions(+), 32 deletions(-)
diff --git a/NEWS b/NEWS
index 053f46f0a..551662867 100644
--- a/NEWS
+++ b/NEWS
@@ -93,6 +93,9 @@ every line in a file.
** When -flto is enabled configure now adds -ffat-lto-objects if it exists
Otherwise libguile.a can end up with no code.
https://lintian.debian.org/tags/no-code-sections.html
+** r6rs-ports.test custom ports tests should no longer fail on stray closes
+ Previously the custom ports weren't explicitly closed, causing
+ GC-related closes to produce spurious "log" events in other tests.
Changes in 3.0.10 (since 3.0.9)
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index dbcc89a93..c782b65f3 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1652,15 +1652,25 @@ not `set-port-position!'"
(with-test-prefix "custom textual ports"
(let ((log '()))
+ (define (clear-log!) (set! log '()))
(define (log! tag args)
(set! log (acons tag args log)))
(define (log-calls tag) (lambda args (log! tag args)))
(define (call-with-logged-calls thunk)
(log! 'result (list (thunk)))
(let ((result (reverse log)))
- (set! log '())
+ (clear-log!)
result))
+ (define-syntax-rule (with-final proc body ...)
+ (let ((reentry? #f))
+ (dynamic-wind (lambda ()
+ (if reentry?
+ (error "not reentrant")
+ (set! reentry? #t)))
+ (lambda () body ...)
+ (lambda () proc))))
+
(define-syntax-rule (pass-if-log-matches id expected expr)
(pass-if id
(match (call-with-logged-calls (lambda () expr))
@@ -1670,33 +1680,35 @@ not `set-port-position!'"
(define (test-input-port id make-port)
(define (call-with-input-string str proc)
(define pos 0)
- (proc
- (make-port id
- (lambda (buf start count)
- (let ((count (min count (- (string-length str) pos))))
- (log! 'read (list count))
- (string-copy! buf start str pos (+ pos count))
- (set! pos (+ pos count))
- count))
- (log-calls 'get-position)
- (log-calls 'set-position)
- (log-calls 'close))))
+ (let ((port (make-port id
+ (lambda (buf start count)
+ (let ((count (min count (- (string-length
str) pos))))
+ (log! 'read (list count))
+ (string-copy! buf start str pos (+ pos
count))
+ (set! pos (+ pos count))
+ count))
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close))))
+ (with-final (close port) (proc port))))
(with-test-prefix id
- (pass-if-log-matches
- "make"
- (('result #t))
- (input-port? (make-port
- "hey"
- (log-calls 'read)
- (log-calls 'get-position)
- (log-calls 'set-position)
- (log-calls 'close))))
+ (let ((port (make-port "hey"
+ (log-calls 'read)
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close))))
+ (with-final
+ (close port)
+ (pass-if-log-matches "make" (('result #t)) (input-port? port))))
+ (pass-if-equal '((close)) log)
+ (clear-log!)
(pass-if-log-matches
"inputting \"foo\""
(('read 3)
('read 0)
+ ('close)
('result "foo"))
(call-with-input-string "foo" get-string-all))
@@ -1706,6 +1718,7 @@ not `set-port-position!'"
(('read 1024)
('read 976)
('read 0)
+ ('close)
('result (? (lambda (x) (equal? x big-str)))))
(call-with-input-string big-str get-string-all)))))
@@ -1721,20 +1734,20 @@ not `set-port-position!'"
(log-calls 'get-position)
(log-calls 'set-position)
(log-calls 'close)))
- (proc port)
- (close-port port)
+ (with-final (close port) (proc port))
(string-concatenate-reverse out))
(with-test-prefix id
- (pass-if-log-matches
- "make"
- (('result #t))
- (output-port? (make-port
- "hey"
- (log-calls 'write)
- (log-calls 'get-position)
- (log-calls 'set-position)
- (log-calls 'close)))))
+ (let ((port (make-port "hey"
+ (log-calls 'write)
+ (log-calls 'get-position)
+ (log-calls 'set-position)
+ (log-calls 'close))))
+ (with-final
+ (close port)
+ (pass-if-log-matches "make" (('result #t)) (output-port? port)))))
+ (pass-if-equal '((close)) log)
+ (clear-log!)
(with-test-prefix id
(pass-if-log-matches
