- port-has-port-position? and port-position are now honest wrt

the supplied arguments for custom port constructors.

scheme/ikarus.io.ss

@@ -275,18 +275,16 @@
                        (- pos (- ($port-size p) index))
                        (+ pos index))
                    (die who "invalid returned value from get-position" p)))]
-            [(eqv? get-position #f)
+            [(eqv? get-position #t)
              (+ (vector-ref pos-vec 0) index)]
             [else 
-             (error who "port does not supprt port-position openration" p)]))
+             (die who "port does not support port-position operation" p)]))
         (die who "not a port" p)))
 
   (define (port-has-port-position? p)
     (define who 'port-has-port-position?)
     (if (port? p)
-        (let ([get-position ($port-get-position p)])
-          (or (procedure? get-position)
-              (not get-position)))
+        (and ($port-get-position p) #t)
         (die who "not a port" p)))
              
   (define guarded-port
@@ -448,8 +446,8 @@
           "*bytevector-input-port*" 
           (lambda (bv i c) 0) ;;; read!
           #f ;;; write!
-          #f 
-          #f
+          #t ;;; get-position
+          #f ;;; set-position!
           #f ;;; close
           #f
           (vector 0))]))
@@ -476,10 +474,10 @@
                          (bytevector-copy! bv i x 0 c)
                          (set! buf* (cons x buf*))))
                      c)
-                   #f
-                   #f
-                   #f
-                   #f
+                   #t ;;; get-position
+                   #f ;;; set-position!
+                   #f ;;; close
+                   #f ;;; cookie
                    (vector 0))])
            (values
              p
@@ -563,9 +561,9 @@
                (set-output-string-cookie-strings! cookie
                  (cons x (output-string-cookie-strings cookie)))))
            c)
-         #f
-         #f
-         #f
+         #t ;;; get-position
+         #f ;;; set-position!
+         #f ;;; close!
          cookie
          (vector 0))))
 
@@ -618,10 +616,10 @@
        id
        (lambda (str i c) 0) ;;; read!
        #f ;;; write!
-       #f
-       #f
+       #t ;;; get-position
+       #f ;;; set-position!
        #f ;;; close
-       #f
+       #f ;;; cookie
        (vector 0)))
 
   (define (open-string-input-port str)
@@ -1421,7 +1419,7 @@
                                    (make-i/o-read-error))])))])
                   refill)
                 #f ;;; write!
-                #f ;;; get-position
+                #t ;;; get-position
                 #f ;;; set-position!
                 (cond
                   [(procedure? close) close]
@@ -1460,7 +1458,7 @@
                                  (io-error 'write id bytes
                                     (make-i/o-write-error))])))])
                   refill)
-                #f ;;; get-position
+                #t ;;; get-position
                 #f ;;; set-position!
                 (cond
                   [(procedure? close) close]

scheme/last-revision

@@ -1 +1 @@
-1668
+1669

scheme/tests/io.ss

@@ -509,7 +509,7 @@
                 '()
                 (cons x (f)))))))))
   
-(define (file-size filename)
+(define (file-size-char-by-char filename)
   (with-input-from-file filename
     (lambda ()
       (let f ([i 0])
@@ -541,6 +541,7 @@
       (f (fx+ i 1)))))
 
 (define (test-input-files)
+  (assert (= (file-size-char-by-char "tests/SRFI-1.ss") 56573))
   (assert (= (file-size "tests/SRFI-1.ss") 56573))
   (let ([bv (file->bytevector "tests/SRFI-1.ss")])
     (let-values ([(p extract) (open-bytevector-output-port #f)])
@@ -666,11 +667,29 @@
     [(lambda (x) (equal? x "abcd"))
      (get-line (open-string-input-port "abcd\nefg"))])
 
-(define (run-tests)
-  (test-custom-binary-input-ports)
-  (test-custom-binary-output-ports)
-  (run-exhaustive-tests)
-  (test-input-files)
-  (test-partial-reads)
-  (test-input-ports))
+  (define (test-has-port-position)
+    (define-syntax check
+      (syntax-rules ()
+        [(_ e) 
+         (begin ;;; evaluating e twice
+           (assert (not (port-has-port-position? e)))
+           (assert
+             (guard (con
+                      [(assertion-violation? con) #t]
+                      [else                       #f])
+               (begin (port-position e) #f))))]))
+    (check (make-custom-binary-input-port "foo" (lambda a 0) #f #f #f))
+    (check (make-custom-binary-output-port "foo" (lambda a 0) #f #f #f))
+    (check (make-custom-textual-input-port "foo" (lambda a 0) #f #f #f))
+    (check (make-custom-textual-output-port "foo" (lambda a 0) #f #f #f)))
+
+  (define (run-tests)
+    (test-custom-binary-input-ports)
+    (test-custom-binary-output-ports)
+    (run-exhaustive-tests)
+    (test-input-files)
+    (test-partial-reads)
+    (test-input-ports)
+    (test-has-port-position))
+
 )