(define sys-seek (foreign-lambda int "lseek" integer integer int)) (define-foreign-variable seek-set int "SEEK_SET") (define (impl:read-write-loop/port-both src dst offset bytes) (set! *last-selected-implementation* 'read-write-loop) (when (positive? offset) (port-seek src offset)) (let* ((buffsize (read-write-buffer-size)) (buffer (make-string buffsize))) (let loop ((bytes-left bytes) (bytes-read 0)) (if (and bytes-left (not (positive? bytes-left))) bytes-read (let* ((to-read (fxmin buffsize (if bytes-left (inexact->exact bytes-left) buffsize))) (read-bytes (read-string! to-read buffer src))) (if (= 0 read-bytes) bytes-read (begin (write-string buffer read-bytes dst) (loop (and bytes-left (- bytes-left read-bytes)) (+ bytes-read read-bytes)))))))) bytes) (define (port-seek port bytes) (let* ((buffsize (read-write-buffer-size)) (buffer (make-string buffsize))) (let loop ((bytes bytes)) (when (positive? bytes) (let ((to-read (fxmin buffsize (inexact->exact bytes)))) (read-string! to-read buffer port) (loop (- bytes to-read))))))) (define (impl:read-write-loop/port src dst offset bytes) (set! *last-selected-implementation* 'read-write-loop) (let* ((buffsize (read-write-buffer-size)) (buffer (make-string buffsize)) (seek (foreign-lambda int "lseek" integer integer int))) (when (positive? offset) (sys-seek src offset seek-set)) (let loop ((bytes-left bytes) (bytes-read 0)) (if (not (positive? bytes-left)) bytes-read (let* ((to-read (fxmin buffsize (inexact->exact bytes-left))) ;; is that ok? doesn't that possibly overflow? (read-bytes (cadr (file-read src to-read buffer)))) (write-string buffer read-bytes dst) (loop (- bytes-left read-bytes) (+ bytes-read read-bytes))))))) (define (impl:read-write-loop/fd src dst offset bytes) (set! *last-selected-implementation* 'read-write-loop) (let* ((buffsize (read-write-buffer-size)) (buffer (make-string buffsize)) (write-timeout (write-timeout)) (write/offset (foreign-lambda* int ((int dst) (nonnull-scheme-pointer buff) (unsigned-integer write_offset) (unsigned-integer bytes)) "C_return(write(dst,buff + write_offset,bytes));")) (write-bytes (lambda (size) (let loop ((bytes-left size) (write_offset 0)) (when (positive? bytes-left) (let ((written-bytes (write/offset dst buffer write_offset bytes-left))) (cond ((zero? bytes-left) #t) ((and (negative? written-bytes) (= errno/again (##sys#update-errno))) (when write-timeout (##sys#thread-block-for-timeout! ##sys#current-thread (+ (current-process-milliseconds) write-timeout))) (##sys#thread-block-for-i/o! ##sys#current-thread dst #:output) (%yield) (when (##sys#slot ##sys#current-thread 13) (complain #f "write operation timed out")) (loop bytes-left write_offset)) ((negative? written-bytes) (complain #t "write failed")) (else (loop (fx- bytes-left written-bytes) (fx+ write_offset written-bytes)))))))))) (when (positive? offset) (sys-seek src offset seek-set)) (let loop ((bytes-left bytes) (bytes-read 0)) (if (not (positive? bytes-left)) bytes-read (let* ((to-read (fxmin buffsize (inexact->exact bytes-left))) (read-bytes (cadr (file-read src to-read buffer)))) (write-bytes read-bytes) (loop (- bytes-left read-bytes) (+ bytes-read read-bytes)))))))