conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

added set-port-position! for binary input files.

This commit is contained in:
Abdulaziz Ghuloum 2008-12-09 03:41:59 -05:00
parent aba76624b2
commit d6a950ae23
3 changed files with 54 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
scheme/ikarus.io.ss
View File

@ -282,11 +282,10 @@
(define (set-port-position! p pos)
(define who 'set-port-position!)
(define (set-input-port-position! p pos) (error who "not yet"))
(define (set-output-port-position! p pos)
(define (set-position! p pos flush?)
(let ([setpos! ($port-set-position! p)])
(unless setpos! (die who "port does not support port position" p))
(flush-output-port p)
(when flush? (flush-output-port p))
(setpos! pos)
($set-port-index! p 0)
($set-port-size! p 0)
@ -295,8 +294,8 @@
(unless (and (or (fixnum? pos) (bignum? pos)) (>= pos 0))
(die who "position must be a nonnegative exact integer" pos))
(cond
[(output-port? p) (set-output-port-position! p pos)]
[(input-port? p) (set-input-port-position! p pos)]
[(output-port? p) (set-position! p pos #t)]
[(input-port? p) (set-position! p pos #f)]
[else (die who "not a port" p)]))
@ -1421,6 +1420,13 @@
"buffer size should be a positive fixnum"
x)))))
(define (make-file-set-position-handler fd id)
(lambda (pos) ;;; set-position!
(let ([err (foreign-call "ikrt_set_position" fd pos)])
(when err
(io-error 'set-position! id err
(make-i/o-invalid-position-error pos))))))
(define (fh->input-port fd id size transcoder close who)
(letrec ([port
($make-port
@ -1450,7 +1456,7 @@
refill)
#f ;;; write!
#t ;;; get-position
#f ;;; set-position!
(make-file-set-position-handler fd id)
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]
@ -1459,6 +1465,7 @@
(vector 0))])
(guarded-port port)))
(define (fh->output-port fd id size transcoder close who)
(letrec ([port
($make-port
@ -1489,11 +1496,7 @@
(make-i/o-write-error))])))])
refill)
#t ;;; get-position
(lambda (pos) ;;; set-position!
(let ([err (foreign-call "ikrt_set_position" fd pos)])
(when err
(io-error 'set-position! id err
(make-i/o-invalid-position-error pos)))))
(make-file-set-position-handler fd id)
(cond
[(procedure? close) close]
[(eqv? close #t) (file-close-proc id fd)]

2
scheme/last-revision
View File

@ -1 +1 @@
1708
1709

61
scheme/tests/set-position.ss
View File

@ -4,30 +4,47 @@
(import (ikarus))
(define fname "temp-test-file")
(define pos-list '([500 12] [720 34] [12 180] [400 4]))
(define (write-bytes)
(when (file-exists? fname) (delete-file fname))
(let ([p (open-file-output-port fname)])
(for-each
(lambda (x)
(set-port-position! p (car x))
(put-u8 p (cadr x)))
pos-list)
(close-output-port p)))
(define (get-bytes)
(let ([p (open-file-input-port fname)])
(let ([bv (get-bytevector-all p)])
(close-input-port p)
bv)))
(define (test-setting-position-for-binary-output-files)
(let ([pos-list '([500 12] [720 34] [12 180] [400 4])])
(when (file-exists? fname) (delete-file fname))
(let ([p (open-file-output-port fname)])
(for-each
(lambda (x)
(set-port-position! p (car x))
(put-u8 p (cadr x)))
pos-list)
(close-output-port p))
(let ([bv
(let ([p (open-file-input-port fname)])
(let ([bv (get-bytevector-all p)])
(close-input-port p)
bv))])
(assert (= (bytevector-length bv)
(add1 (apply max (map car pos-list)))))
(for-each
(lambda (x)
(assert (= (bytevector-u8-ref bv (car x)) (cadr x))))
pos-list))
(delete-file fname)))
(write-bytes)
(let ([bv (get-bytes)])
(assert (= (bytevector-length bv)
(add1 (apply max (map car pos-list)))))
(for-each
(lambda (x)
(assert (= (bytevector-u8-ref bv (car x)) (cadr x))))
pos-list))
(delete-file fname))
(define (test-setting-position-for-binary-input-files)
(write-bytes)
(let ([p (open-file-input-port fname)])
(define (check-pos x)
(set-port-position! p (car x))
(assert (= (get-u8 p) (cadr x))))
(for-each check-pos pos-list)
(for-each check-pos (reverse pos-list))
(close-input-port p))
(delete-file fname))
(define (run-tests)
(test-setting-position-for-binary-output-files)))
(test-setting-position-for-binary-output-files)
(test-setting-position-for-binary-input-files)))