mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

r6rs-ports.test: don't race with gc close in custom port tests

Browse source 
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.
This commit is contained in:
Rob Browning 2025-03-02 13:51:17 -06:00
parent d7475d4073
commit 5012581745
2 changed files with 48 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

3
NEWS
View file

@ -93,6 +93,9 @@ every line in a file.
** When -flto is enabled configure now adds -ffat-lto-objects if it exists ** When -flto is enabled configure now adds -ffat-lto-objects if it exists
Otherwise libguile.a can end up with no code. Otherwise libguile.a can end up with no code.
https://lintian.debian.org/tags/no-code-sections.html 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) Changes in 3.0.10 (since 3.0.9)

77
test-suite/tests/r6rs-ports.test
View file

@ -1652,15 +1652,25 @@ not `set-port-position!'"
(with-test-prefix "custom textual ports" (with-test-prefix "custom textual ports"
(let ((log '())) (let ((log '()))
(define (clear-log!) (set! log '()))
(define (log! tag args) (define (log! tag args)
(set! log (acons tag args log))) (set! log (acons tag args log)))
(define (log-calls tag) (lambda args (log! tag args))) (define (log-calls tag) (lambda args (log! tag args)))
(define (call-with-logged-calls thunk) (define (call-with-logged-calls thunk)
(log! 'result (list (thunk))) (log! 'result (list (thunk)))
(let ((result (reverse log))) (let ((result (reverse log)))
(set! log '()) (clear-log!)
result)) 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) (define-syntax-rule (pass-if-log-matches id expected expr)
(pass-if id (pass-if id
(match (call-with-logged-calls (lambda () expr)) (match (call-with-logged-calls (lambda () expr))
@ -1670,33 +1680,35 @@ not `set-port-position!'"
(define (test-input-port id make-port) (define (test-input-port id make-port)
(define (call-with-input-string str proc) (define (call-with-input-string str proc)
(define pos 0) (define pos 0)
(proc (let ((port (make-port id
(make-port id (lambda (buf start count)
(lambda (buf start count) (let ((count (min count (- (string-length str) pos))))
(let ((count (min count (- (string-length str) pos)))) (log! 'read (list count))
(log! 'read (list count)) (string-copy! buf start str pos (+ pos count))
(string-copy! buf start str pos (+ pos count)) (set! pos (+ pos count))
(set! pos (+ pos count)) count))
count)) (log-calls 'get-position)
(log-calls 'get-position) (log-calls 'set-position)
(log-calls 'set-position) (log-calls 'close))))
(log-calls 'close)))) (with-final (close port) (proc port))))
(with-test-prefix id (with-test-prefix id
(pass-if-log-matches (let ((port (make-port "hey"
"make" (log-calls 'read)
(('result #t)) (log-calls 'get-position)
(input-port? (make-port (log-calls 'set-position)
"hey" (log-calls 'close))))
(log-calls 'read) (with-final
(log-calls 'get-position) (close port)
(log-calls 'set-position) (pass-if-log-matches "make" (('result #t)) (input-port? port))))
(log-calls 'close)))) (pass-if-equal '((close)) log)
(clear-log!)
(pass-if-log-matches (pass-if-log-matches
"inputting \"foo\"" "inputting \"foo\""
(('read 3) (('read 3)
('read 0) ('read 0)
('close)
('result "foo")) ('result "foo"))
(call-with-input-string "foo" get-string-all)) (call-with-input-string "foo" get-string-all))
@ -1706,6 +1718,7 @@ not `set-port-position!'"
(('read 1024) (('read 1024)
('read 976) ('read 976)
('read 0) ('read 0)
('close)
('result (? (lambda (x) (equal? x big-str))))) ('result (? (lambda (x) (equal? x big-str)))))
(call-with-input-string big-str get-string-all))))) (call-with-input-string big-str get-string-all)))))
@ -1721,20 +1734,20 @@ not `set-port-position!'"
(log-calls 'get-position) (log-calls 'get-position)
(log-calls 'set-position) (log-calls 'set-position)
(log-calls 'close))) (log-calls 'close)))
(proc port) (with-final (close port) (proc port))
(close-port port)
(string-concatenate-reverse out)) (string-concatenate-reverse out))
(with-test-prefix id (with-test-prefix id
(pass-if-log-matches (let ((port (make-port "hey"
"make" (log-calls 'write)
(('result #t)) (log-calls 'get-position)
(output-port? (make-port (log-calls 'set-position)
"hey" (log-calls 'close))))
(log-calls 'write) (with-final
(log-calls 'get-position) (close port)
(log-calls 'set-position) (pass-if-log-matches "make" (('result #t)) (output-port? port)))))
(log-calls 'close))))) (pass-if-equal '((close)) log)
(clear-log!)
(with-test-prefix id (with-test-prefix id
(pass-if-log-matches (pass-if-log-matches