1#lang racket/base 2(require "../common/check.rkt" 3 "../common/class.rkt" 4 "../host/thread.rkt" 5 "parameter.rkt" 6 "port.rkt" 7 "input-port.rkt" 8 "count.rkt" 9 "check.rkt") 10 11(provide (rename-out [progress-evt?* progress-evt?]) 12 port-provides-progress-evts? 13 port-progress-evt 14 port-commit-peeked 15 16 check-progress-evt 17 unwrap-progress-evt) 18 19(struct progress-evt (port evt) 20 #:property prop:evt (lambda (pe) 21 (wrap-evt (progress-evt-evt pe) 22 (lambda args pe)))) 23 24(define progress-evt?* 25 (let ([progress-evt? 26 (case-lambda 27 [(v) (progress-evt? v)] 28 [(v port) 29 (and (progress-evt? v) 30 (eq? port (progress-evt-port v)))])]) 31 progress-evt?)) 32 33;; ---------------------------------------- 34 35(define/who (port-provides-progress-evts? in) 36 (check who input-port? in) 37 (let ([in (->core-input-port in)]) 38 (and (method core-input-port in get-progress-evt) #t))) 39 40(define/who (port-progress-evt [orig-in (current-input-port)]) 41 (check who input-port? orig-in) 42 (let ([in (->core-input-port orig-in)]) 43 (define get-progress-evt (method core-input-port in get-progress-evt)) 44 (if get-progress-evt 45 (progress-evt orig-in (get-progress-evt in)) 46 (raise-arguments-error 'port-progress-evt 47 "port does not provide progress evts" 48 "port" orig-in)))) 49 50(define/who (port-commit-peeked amt progress-evt evt [in (current-input-port)]) 51 (check who exact-nonnegative-integer? amt) 52 (check who progress-evt? progress-evt) 53 (check who sync-atomic-poll-evt? 54 #:contract "(or/c channel-put-evt? channel? semaphore? semaphore-peek-evt? always-evt never-evt)" 55 evt) 56 (check who input-port? in) 57 (check-progress-evt who progress-evt in) 58 (let ([in (->core-input-port in)]) 59 (atomically 60 ;; We specially skip a check on whether the port is closed, 61 ;; since that's handled as the progress evt becoming ready 62 (send core-input-port in commit 63 amt (progress-evt-evt progress-evt) evt 64 ;; in atomic mode (but maybe leaves atomic mode in between) 65 (lambda (bstr) 66 (port-count! in (bytes-length bstr) bstr 0)))))) 67 68(define (check-progress-evt who progress-evt in) 69 (unless (progress-evt?* progress-evt in) 70 (raise-arguments-error who "evt is not a progress evt for the given port" 71 "evt" progress-evt 72 "port" in))) 73 74(define (unwrap-progress-evt progress-evt) 75 (and progress-evt 76 (progress-evt-evt progress-evt))) 77