From 50125817455f466970bbd803a0c51fa9be0d8ba3 Mon Sep 17 00:00:00 2001
From: Rob Browning <rlb@defaultvalue.org>
Date: Sun, 2 Mar 2025 13:51:17 -0600
Subject: [PATCH] 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