Fixes bug 178385: Closed port giving incorrect error about type

instead of about being closed

scheme/ikarus.io.ss

@@ -28,7 +28,7 @@
     make-custom-textual-input-port 
     make-custom-textual-output-port 
     transcoded-port port-transcoder
-    close-port close-input-port close-output-port
+    close-port port-closed? close-input-port close-output-port
     port-eof?
     get-char lookahead-char read-char peek-char
     get-string-n get-string-n! get-string-all get-line
@@ -77,7 +77,7 @@
       make-custom-textual-input-port 
       make-custom-textual-output-port 
       transcoded-port port-transcoder
-      close-port close-input-port close-output-port
+      close-port port-closed? close-input-port close-output-port
       port-eof?
       get-char lookahead-char read-char peek-char
       get-string-n get-string-n! get-string-all get-line
@@ -538,6 +538,12 @@
               
   (define ($port-closed? p) 
     (not (fxzero? (fxand ($port-attrs p) closed-port-tag))))
+
+  (define (port-closed? p) 
+    (if (port? p) 
+        ($port-closed? p) 
+        (error 'port-closed? "not a port" p)))
+
   (define ($mark-port-closed! p) 
     ($set-port-attrs! p 
       (fxior closed-port-tag 
@@ -1786,7 +1792,9 @@
                   (put-char-latin-mode p b who)])))]
           [else 
            (if (output-port? p)
-               (die who "not a textual port" p)
+               (if (textual-port? p) 
+                   (die who "port is closed" p)
+                   (die who "not a textual port" p))
                (die who "not an output port" p))]))))
 
   (define newline

scheme/ikarus.writer.ss

@@ -797,12 +797,11 @@
       (flush-output-port p)))
   
   (define fprintf
-    (lambda (port fmt . args)
-      (unless (output-port? port) 
-        (die 'fprintf "not an output port" port))
+    (lambda (p fmt . args)
+      (assert-open-textual-output-port p 'fprintf)
       (unless (string? fmt)
         (die 'fprintf "not a string" fmt))
-      (formatter 'fprintf port fmt args)))
+      (formatter 'fprintf p fmt args)))
 
   (define display-error
     (lambda (errname who fmt args)
@@ -834,21 +833,18 @@
     (case-lambda
       [(x) (write-to-port x (current-output-port))]
       [(x p)
-       (unless (output-port? p) 
-         (die 'write "not an output port" p))
+       (assert-open-textual-output-port p 'write)
        (write-to-port x p)]))
 
   (define (put-datum p x)
-    (unless (output-port? p) 
-      (die 'put-datum "not an output port" p))
+    (assert-open-textual-output-port p 'put-datum)
     (write-to-port x p))
 
   (define display 
     (case-lambda
       [(x) (display-to-port x (current-output-port))]
       [(x p)
-       (unless (output-port? p) 
-         (die 'display "not an output port" p))
+       (assert-open-textual-output-port p 'display)
        (display-to-port x p)]))
 
   (define print-error 
@@ -859,5 +855,13 @@
     (lambda (who fmt . args)
       (display-error "Warning" who fmt args)))
 
+  (define (assert-open-textual-output-port p who)
+    (unless (output-port? p) 
+      (die who "not an output port" p))
+    (unless (textual-port? p) 
+      (die who "not a textual port" p))
+    (when (port-closed? p) 
+      (die who "port is closed" p)))
+
   )
 

scheme/last-revision

@@ -1 +1 @@
-1283
+1284

scheme/makefile.ss

@@ -1293,6 +1293,7 @@
     [annotation-expression i]
     [annotation-source     i]
     [annotation-stripped   i]
+    [port-closed?          i]
     [$make-port           $io]
     [$port-tag            $io]
     [$port-id             $io]