~ chicken-core (master) 430eea9aad5c5e9db8acd4bcf2b5f8df2b83d7d3

commit 430eea9aad5c5e9db8acd4bcf2b5f8df2b83d7d3
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Fri Sep 25 14:36:10 2026 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Sep 25 18:32:49 2026 +0200

    Make argument port checks precise when the direction is known
    
    Notably in close-input-port/close-output-port, the direction the port
    *should* have is known, but silently ignored.
    
    We want repeated calls to port-close to be silently ignored, but this
    results in a bit of a footgun when combined with confusion regarding
    port direction for process objects, where process-output-port actually
    returns an *input* port (because the name is viewed from perspective
    of the child process).
    
    Other places where we know the direction are copy-port (for port
    arguments) and get-output-bytevector and the setters for the current
    input, output and error ports.  Update those as well to be extra safe,
    and actually match the ports in types.db, where they're marked as
    enforcing.  This means it's actually incorrect to ignore direction.
    
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/NEWS b/NEWS
index 853767d9..72f07f14 100644
--- a/NEWS
+++ b/NEWS
@@ -58,6 +58,10 @@
     bytevectors inside bytevector literals are spliced, allowing for various
     ways to construct complex byte sequences (thanks to Kristian 
     Lein-Mathisen).
+  - Procedures expecting specifically input or output ports now check
+    whether their port argument is of the correct direction.  Previously
+    e.g. close-input-port would silently ignore output port arguments
+    (thanks to Étienne Pflieger).
 
 - Syntax expander
   - Fixed bug in handling of "export-all" library declaration which caused
diff --git a/library.scm b/library.scm
index f3361a91..2930e758 100644
--- a/library.scm
+++ b/library.scm
@@ -1319,7 +1319,7 @@ EOF
 (set! scheme#get-output-bytevector
  (lambda (p)
   (define (fail) (error 'get-output-bytevector "not an output-bytevector" p))
-  (##sys#check-port p 'get-output-bytevector)
+  (##sys#check-output-port p 'get-output-bytevector)
   (if (eq? (##sys#slot p 7) 'custom)
       (let ((getter (##sys#slot p 9)))
         (if (procedure? getter)
@@ -4481,7 +4481,7 @@ EOF
     (if (null? args)
 	##sys#standard-input
 	(let ((p (car args)))
-	  (##sys#check-port p 'current-input-port)
+	  (##sys#check-input-port p 'current-input-port)
 	  (let-optionals (cdr args) ((convert? #t) (set? #t))
 	    (when set? (set! ##sys#standard-input p)))
 	  p) ) ))
@@ -4491,7 +4491,7 @@ EOF
     (if (null? args)
 	##sys#standard-output
 	(let ((p (car args)))
-	  (##sys#check-port p 'current-output-port)
+	  (##sys#check-output-port p 'current-output-port)
 	  (let-optionals (cdr args) ((convert? #t) (set? #t))
 	    (when set? (set! ##sys#standard-output p)))
 	  p) ) ))
@@ -4501,7 +4501,7 @@ EOF
     (if (null? args)
 	##sys#standard-error
 	(let ((p (car args)))
-	  (##sys#check-port p 'current-error-port)
+	  (##sys#check-output-port p 'current-error-port)
 	  (let-optionals (cdr args) ((convert? #t) (set? #t))
 	    (when set? (set! ##sys#standard-error p)))
 	  p))))
@@ -4551,7 +4551,9 @@ EOF
         port) ) )
 
   (define (close port inp loc)
-    (##sys#check-port port loc)
+    (if inp
+        (##sys#check-input-port port loc)
+        (##sys#check-output-port port loc))
     ; repeated closing is ignored
     (let ((direction (if inp 1 2)))
       (when (##core#inline "C_port_openp" port direction)
diff --git a/port.scm b/port.scm
index 52641dbb..b2de9937 100644
--- a/port.scm
+++ b/port.scm
@@ -192,8 +192,8 @@ char *ttyname(int fd) {
   (let ((read-char read-char)
         (write-char write-char))
     (define (read-and-write src dest)
-      (##sys#check-port src 'copy-port)
-      (##sys#check-port dest 'copy-port)
+      (##sys#check-input-port src 'copy-port)
+      (##sys#check-output-port dest 'copy-port)
       (let ((buf (##sys#make-bytevector +buf-size+)))
         (let loop ()
           (let ((n (chicken.io#read-bytevector!/port +buf-size+ buf src 0)))
@@ -201,7 +201,7 @@ char *ttyname(int fd) {
               (chicken.io#write-bytevector buf dest 0 n)
               (loop))))))
     (define (read-and-delegate src dest writer)
-      (##sys#check-port src 'copy-port)
+      (##sys#check-input-port src 'copy-port)
       (let ((buf (##sys#make-bytevector +buf-size+)))
         (let loop ((p 0))
           (let* ((n (chicken.io#read-bytevector!/port
@@ -228,7 +228,7 @@ char *ttyname(int fd) {
             (writer x dest)
             (loop)))))
     (define (delegate-and-write src reader dest)
-      (##sys#check-port dest 'copy-port)
+      (##sys#check-output-port dest 'copy-port)
       (let ((buf (##sys#make-bytevector (fx+ 4 +buf-size+))))
         (let loop ((n 0))
           (when (fx>= n +buf-size+)