diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss index 9b29873..59505a2 100644 --- a/scheme/ikarus.io.ss +++ b/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] diff --git a/scheme/last-revision b/scheme/last-revision index 75c2bf7..7fb595a 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1668 +1669 diff --git a/scheme/tests/io.ss b/scheme/tests/io.ss index 3ac8ab0..ed1194e 100755 --- a/scheme/tests/io.ss +++ b/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)) + )