io: clean up unneeded scaffolding
Everything is converted, so we don't need the scaffolding anymore.
This commit is contained in:
Matthew Flatt
parent
40f27f8153
commit
a382c6ca72
|
|
@ -1,267 +0,0 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/pretty)
|
||||
racket/stxparam
|
||||
"fixnum.rkt")
|
||||
|
||||
;; The `define-constructor` form implements a basic object system
|
||||
;; where any `(define (id ....) ....)` or `(define id (case-lambda
|
||||
;; ....)` in the constructor body is treated as a method that is
|
||||
;; converted to accept a vector of free variables.
|
||||
;;
|
||||
;; A `lambda` or `case-lambda` is any other position can be wrapped in
|
||||
;; `method` to convert it, too. Note that the caller of such methods
|
||||
;; must know to pass along the self vector somehow. The `self`
|
||||
;; identifier is bound to the self vector.
|
||||
;;
|
||||
;; Constraints:
|
||||
;;
|
||||
;; Macros are not expanded to recognize definitions; use only
|
||||
;; `define` or `define-fixnum` for definitions.
|
||||
;;
|
||||
;; Only `set!` any variables within a method.
|
||||
;;
|
||||
;; A named method cannot be used as a value unless it is wrapped
|
||||
;; with `method`; calls are automatcally converted to pass along the
|
||||
;; self vector, while the `method` escape obliges a called of the
|
||||
;; result to pass along the self vector.
|
||||
|
||||
(provide define-constructor
|
||||
method
|
||||
self)
|
||||
|
||||
(define-syntax-parameter self
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "misuse outside of a constructor" stx)))
|
||||
|
||||
(define-syntax-parameter current-constructor-fields #f)
|
||||
(define-syntax-parameter current-constructor-methods #f)
|
||||
|
||||
(define-for-syntax (get-current-constructor-fields)
|
||||
(syntax-parameter-value #'current-constructor-fields))
|
||||
(define-for-syntax (get-current-constructor-methods)
|
||||
(syntax-parameter-value #'current-constructor-methods))
|
||||
|
||||
(define-for-syntax (maybe-lift mode e)
|
||||
(syntax-case mode ()
|
||||
[#:lift (syntax-local-lift-expression e)]
|
||||
[#:no-lift e]))
|
||||
|
||||
(define-syntax (method stx)
|
||||
(syntax-case stx (lambda case-lambda)
|
||||
[(_ id)
|
||||
(identifier? #'id)
|
||||
#'(id #:method)]
|
||||
[(_ rhs)
|
||||
#'(method #:lift rhs)]
|
||||
[(_ lift-mode (lambda (arg ...) body ...))
|
||||
(with-syntax ([fields (get-current-constructor-fields)]
|
||||
[methods (get-current-constructor-methods)]
|
||||
[(_ _ inside) stx])
|
||||
(maybe-lift
|
||||
#'lift-mode
|
||||
#`(lambda (this arg ...)
|
||||
(let-methods
|
||||
this methods inside
|
||||
(let-fields
|
||||
this 0 fields inside
|
||||
body ...)))))]
|
||||
[(_ lift-mode (case-lambda [(arg ...) body ...] ...))
|
||||
(with-syntax ([fields (get-current-constructor-fields)]
|
||||
[methods (get-current-constructor-methods)]
|
||||
[(_ _ inside) stx])
|
||||
(maybe-lift
|
||||
#'lift-mode
|
||||
#`(case-lambda
|
||||
[(this arg ...)
|
||||
(let-methods
|
||||
this methods inside
|
||||
(let-fields
|
||||
this 0 fields inside
|
||||
body ...))]
|
||||
...)))]))
|
||||
|
||||
(define-for-syntax (make-method-transformer self-id id)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:method) id]
|
||||
[(_ arg ...) (quasisyntax/loc stx
|
||||
(#,id #,self-id arg ...))])))
|
||||
|
||||
(define-syntax (define-constructor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name arg ...) body ... last-body)
|
||||
(andmap identifier? (syntax->list #'(arg ...)))
|
||||
(let ()
|
||||
(define fields
|
||||
(apply append
|
||||
(syntax->list #'(arg ...))
|
||||
(for/list ([body (in-list (syntax->list #'(body ...)))])
|
||||
(syntax-case body (define case-lambda define-values define-fixnum)
|
||||
[(define (id . _) . _)
|
||||
null]
|
||||
[(define id (case-lambda . _))
|
||||
null]
|
||||
[(define id _)
|
||||
(list #'id)]
|
||||
[(define-values (id ...) _)
|
||||
(syntax->list #'(id ...))]
|
||||
[(define-fixnum id _)
|
||||
(list #'(capture-fixnum id))]
|
||||
[else
|
||||
null]))))
|
||||
(define methods
|
||||
(apply
|
||||
append
|
||||
(for/list ([body (in-list (syntax->list #'(body ...)))])
|
||||
(syntax-case body (define define-values define-fixnum case-lambda)
|
||||
[(define (id . args) . bodys)
|
||||
(list (cons #'id (generate-temporaries #'(id))))]
|
||||
[(define id (case-lambda . clauses))
|
||||
(list (cons #'id (generate-temporaries #'(id))))]
|
||||
[_ null]))))
|
||||
(define (find-method-name id)
|
||||
(for/or ([pr (in-list methods)])
|
||||
(and (free-identifier=? id (car pr))
|
||||
(cadr pr))))
|
||||
(define num-args (length (syntax->list #'(arg ...))))
|
||||
(define-values (method-defns other-bodys count)
|
||||
(for/fold ([method-defns null] [other-bodys null] [n num-args]) ([body (in-list (syntax->list #'(body ...)))])
|
||||
(syntax-case body (define define-values define-fixnum case-lambda)
|
||||
[(define (id . args) . bodys)
|
||||
(let ([re (lambda (s) (datum->syntax body (syntax-e s) body body))]
|
||||
[tmp-id (find-method-name #'id)])
|
||||
(values (cons #`(define #,tmp-id
|
||||
(syntax-parameterize ([current-constructor-fields (quote-syntax #,fields)]
|
||||
[current-constructor-methods (quote-syntax #,methods)])
|
||||
(method #:no-lift #,(re #'(lambda args . bodys)))))
|
||||
method-defns)
|
||||
other-bodys
|
||||
n))]
|
||||
[(define id (case-lambda . clauses))
|
||||
(let ([re (lambda (s) (datum->syntax body (syntax-e s) body body))]
|
||||
[tmp-id (find-method-name #'id)])
|
||||
(values (cons #`(define #,tmp-id
|
||||
(syntax-parameterize ([current-constructor-fields (quote-syntax #,fields)]
|
||||
[current-constructor-methods (quote-syntax #,methods)])
|
||||
(method #:no-lift #,(re #'(case-lambda clauses)))))
|
||||
method-defns)
|
||||
other-bodys
|
||||
n))]
|
||||
[(define id _)
|
||||
(values method-defns
|
||||
(list* #`(vector*-set! self-vec #,n id)
|
||||
body
|
||||
other-bodys)
|
||||
(add1 n))]
|
||||
[(define-values (id ...) _)
|
||||
(values method-defns
|
||||
(list* #`(begin #,@(for/list ([id (in-list (syntax->list #'(id ...)))]
|
||||
[n (in-naturals n)])
|
||||
#`(vector*-set! self-vec #,n #,id)))
|
||||
body
|
||||
other-bodys)
|
||||
(+ n (length (syntax->list #'(id ...)))))]
|
||||
[(define-fixnum id _)
|
||||
(values method-defns
|
||||
(list* #`(vector*-set! self-vec #,n (capture-fixnum id))
|
||||
body
|
||||
other-bodys)
|
||||
(add1 n))]
|
||||
[else
|
||||
(values method-defns
|
||||
(cons body other-bodys)
|
||||
n)])))
|
||||
(with-syntax ([inside stx]
|
||||
[count #`#,count]
|
||||
[fields fields]
|
||||
[methods methods]
|
||||
[(init-arg ...) (for/list ([arg (in-list (syntax->list #'(arg ...)))]
|
||||
[i (in-naturals)])
|
||||
#`(vector*-set! self-vec #,i #,arg))]
|
||||
[(other-body ...) (reverse other-bodys)]
|
||||
[(method-defn ...) (reverse method-defns)])
|
||||
#'(begin
|
||||
method-defn ...
|
||||
(define (name arg ...)
|
||||
(define self-vec (make-vector count))
|
||||
init-arg ...
|
||||
(syntax-parameterize ([current-constructor-fields (quote-syntax fields)]
|
||||
[current-constructor-methods (quote-syntax methods)]
|
||||
[self (lambda (stx) #'self-vec)])
|
||||
(let-methods
|
||||
self-vec methods inside
|
||||
(let ()
|
||||
other-body ...
|
||||
last-body)))))))]
|
||||
[(_ (name . formals) body ... last-body)
|
||||
(with-syntax ([(arg ...) (let loop ([formals #'formals])
|
||||
(syntax-case formals ()
|
||||
[() null]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(list #'id)]
|
||||
[(kw . formals)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(loop #'formals)]
|
||||
[([id _] . formals)
|
||||
(cons #'id (loop #'formals))]
|
||||
[(id . formals)
|
||||
(cons #'id (loop #'formals))]))])
|
||||
#`(begin
|
||||
#,(datum->syntax
|
||||
stx
|
||||
(syntax-e #'(define-constructor (constructor arg ...)
|
||||
body ... last-body))
|
||||
stx
|
||||
stx)
|
||||
(define (name . formals)
|
||||
(constructor arg ...))))]))
|
||||
|
||||
(define-syntax (let-fields stx)
|
||||
(syntax-case stx (capture-fixnum)
|
||||
[(_ self-id n () ctx body ...)
|
||||
#'(let () body ...)]
|
||||
[(_ self-id n ((capture-fixnum id) . captureds) ctx . bodys)
|
||||
(with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))]
|
||||
[n+1 #`#,(+ (syntax-e #'n) 1)])
|
||||
#'(let-syntax ([id (make-fixnum-transformer #'(vector*-ref self-id n))])
|
||||
(let-fields self-id n+1 captureds ctx . bodys)))]
|
||||
[(_ self-id n (id . captureds) ctx . bodys)
|
||||
(with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))]
|
||||
[n+1 #`#,(+ (syntax-e #'n) 1)])
|
||||
#'(let-syntax ([id (make-set!-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ r) #'(vector*-set! self-id n r)]
|
||||
[(_ arg (... ...)) #'((vector*-ref self-id n) arg (... ...))]
|
||||
[_ #'(vector*-ref self-id n)])))])
|
||||
(let-fields self-id n+1 captureds ctx . bodys)))]))
|
||||
|
||||
(define-syntax (let-methods stx)
|
||||
(syntax-case stx ()
|
||||
[(_ self-id () ctx body ...)
|
||||
#'(let () body ...)]
|
||||
[(_ self-id ((id tmp-id) . methods) ctx . bodys)
|
||||
(with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))])
|
||||
#'(let-syntax ([id (make-method-transformer #'self-id #'tmp-id)])
|
||||
(let-methods self-id methods ctx . bodys)))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(module+ test
|
||||
(define-constructor (c x y)
|
||||
(define a 12)
|
||||
(define-fixnum z 120)
|
||||
(define (f)
|
||||
(set! z 130)
|
||||
(set! y 8)
|
||||
(list a x (g)))
|
||||
(define (g)
|
||||
(list y z))
|
||||
(values (method f)
|
||||
self))
|
||||
|
||||
(define-values (f f-self) (c 1 2))
|
||||
(f f-self))
|
||||
|
||||
|
|
@ -9,9 +9,7 @@
|
|||
(provide prop:input-port
|
||||
input-port?
|
||||
->core-input-port
|
||||
(struct-out core-input-port)
|
||||
make-core-input-port
|
||||
compat-input-port-self)
|
||||
(struct-out core-input-port))
|
||||
|
||||
(define-values (prop:input-port input-port-via-property? input-port-ref)
|
||||
(make-struct-type-property 'input-port
|
||||
|
|
@ -147,67 +145,3 @@
|
|||
(define empty-input-port
|
||||
(new core-input-port
|
||||
[name 'empty]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(class compat-input-port #:extends core-input-port
|
||||
(field
|
||||
[self #f]))
|
||||
|
||||
(define (make-core-input-port #:name name
|
||||
#:data [data #f]
|
||||
#:self self
|
||||
#:prepare-change [prepare-change #f]
|
||||
#:read-byte [read-byte #f]
|
||||
#:read-in read-in
|
||||
#:peek-byte [peek-byte #f]
|
||||
#:peek-in peek-in
|
||||
#:byte-ready byte-ready
|
||||
#:close close
|
||||
#:get-progress-evt [get-progress-evt #f]
|
||||
#:commit [commit #f]
|
||||
#:get-location [get-location #f]
|
||||
#:count-lines! [count-lines! #f]
|
||||
#:init-offset [init-offset 0]
|
||||
#:file-position [file-position #f]
|
||||
#:buffer-mode [buffer-mode #f])
|
||||
(new compat-input-port
|
||||
#:override
|
||||
([close (and #t (lambda (in) (close self)))]
|
||||
[count-lines! (and count-lines! (lambda (in) (count-lines! self)))]
|
||||
[get-location (and get-location (lambda (in) (get-location self)))]
|
||||
[file-position (and file-position
|
||||
(if (input-port? file-position)
|
||||
file-position
|
||||
(if (procedure-arity-includes? file-position 2)
|
||||
(case-lambda
|
||||
[(in) (file-position self)]
|
||||
[(in pos) (file-position self pos)])
|
||||
(lambda (out) (file-position self)))))]
|
||||
[buffer-mode
|
||||
(and buffer-mode (case-lambda
|
||||
[(in) (buffer-mode self)]
|
||||
[(in mode) (buffer-mode self mode)]))]
|
||||
[prepare-change (and prepare-change (lambda (in) (prepare-change self)))]
|
||||
[read-in
|
||||
(if (input-port? read-in)
|
||||
read-in
|
||||
(lambda (in bstr start end copy?)
|
||||
(read-in self bstr start end copy?)))]
|
||||
[peek-in
|
||||
(if (input-port? peek-in)
|
||||
peek-in
|
||||
(lambda (in bstr start end skip progress-evt copy?)
|
||||
(peek-in self bstr start end skip progress-evt copy?)))]
|
||||
[byte-ready
|
||||
(if (input-port? byte-ready)
|
||||
byte-ready
|
||||
(lambda (in work-done!) (byte-ready self work-done!)))]
|
||||
[get-progress-evt (and get-progress-evt (lambda (in) (get-progress-evt self)))]
|
||||
[commit (and #t (lambda (in amt-k progress-evt? evt? finish)
|
||||
(commit self amt-k progress-evt? evt? finish)))])
|
||||
;; fields
|
||||
[name name]
|
||||
[offset init-offset]
|
||||
[data data]
|
||||
[self self]))
|
||||
|
|
|
|||
40
racket/src/io/port/max-output-port.rkt
Normal file
40
racket/src/io/port/max-output-port.rkt
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
#lang racket/base
|
||||
(require "../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"output-port.rkt"
|
||||
"bytes-output.rkt")
|
||||
|
||||
(provide make-max-output-port
|
||||
max-output-port-max-length)
|
||||
|
||||
(class max-output-port #:extends core-output-port
|
||||
(field
|
||||
[o #f]
|
||||
[max-length 0])
|
||||
(override
|
||||
[write-out
|
||||
(lambda (src-bstr src-start src-end nonblock? enable-break? copy?)
|
||||
(cond
|
||||
[max-length
|
||||
(define len (- src-end src-start))
|
||||
(unless (eq? max-length 'full)
|
||||
(define write-len (min len max-length))
|
||||
(end-atomic)
|
||||
(define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len)))
|
||||
(start-atomic)
|
||||
(if (= max-length wrote-len)
|
||||
(set! max-length 'full)
|
||||
(set! max-length (- max-length wrote-len))))
|
||||
len]
|
||||
[else
|
||||
(end-atomic)
|
||||
(define len (write-bytes src-bstr o src-start src-end))
|
||||
(start-atomic)
|
||||
len]))]))
|
||||
|
||||
(define (make-max-output-port o max-length)
|
||||
(new max-output-port
|
||||
[name (object-name o)]
|
||||
[evt o]
|
||||
[o o]
|
||||
[max-length max-length]))
|
||||
|
|
@ -10,9 +10,7 @@
|
|||
output-port?
|
||||
->core-output-port
|
||||
(struct-out core-output-port)
|
||||
get-write-evt-via-write-out
|
||||
make-core-output-port
|
||||
compat-output-port-self)
|
||||
get-write-evt-via-write-out)
|
||||
|
||||
(define-values (prop:output-port output-port-via-property? output-port-ref)
|
||||
(make-struct-type-property 'output-port
|
||||
|
|
@ -120,71 +118,3 @@
|
|||
(define empty-output-port
|
||||
(new core-output-port
|
||||
[name 'empty]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(class compat-output-port #:extends core-output-port
|
||||
(field
|
||||
[self #f]))
|
||||
|
||||
(define (make-core-output-port #:name name
|
||||
#:data [data #f]
|
||||
#:self self
|
||||
#:evt evt
|
||||
#:write-out write-out
|
||||
#:close close
|
||||
#:write-out-special [write-out-special #f]
|
||||
#:get-write-evt [get-write-evt #f]
|
||||
#:count-write-evt-via-write-out [count-write-evt-via-write-out #f]
|
||||
#:get-write-special-evt [get-write-special-evt #f]
|
||||
#:get-location [get-location #f]
|
||||
#:count-lines! [count-lines! #f]
|
||||
#:file-position [file-position #f]
|
||||
#:init-offset [init-offset 0]
|
||||
#:buffer-mode [buffer-mode #f])
|
||||
(new compat-output-port
|
||||
#:override
|
||||
([close (and #t (lambda (out) (close self)))]
|
||||
[count-lines! (and count-lines! (lambda (out) (count-lines! self)))]
|
||||
[get-location (and get-location (lambda (out) (get-location self)))]
|
||||
[file-position (and file-position
|
||||
(if (output-port? file-position)
|
||||
file-position
|
||||
(if (procedure-arity-includes? file-position 2)
|
||||
(case-lambda
|
||||
[(out) (file-position self)]
|
||||
[(out pos) (file-position self pos)])
|
||||
(lambda (out) (file-position self)))))]
|
||||
[buffer-mode (and buffer-mode (case-lambda
|
||||
[(out) (buffer-mode self)]
|
||||
[(out mode) (buffer-mode self mode)]))]
|
||||
[write-out
|
||||
(if (output-port? write-out)
|
||||
write-out
|
||||
(lambda (out bstr start-k end-k no-block/buffer? enable-break? copy?)
|
||||
(write-out self bstr start-k end-k no-block/buffer? enable-break? copy?)))]
|
||||
[write-out-special
|
||||
(and write-out-special
|
||||
(if (output-port? write-out-special)
|
||||
write-out-special
|
||||
(lambda (out any no-block/buffer? enable-break?)
|
||||
(write-out-special self any no-block/buffer? enable-break?))))]
|
||||
[get-write-evt
|
||||
(cond
|
||||
[get-write-evt (lambda (out src-bstr src-start src-endv)
|
||||
(get-write-evt self out src-bstr src-start src-endv))]
|
||||
[count-write-evt-via-write-out
|
||||
(get-write-evt-via-write-out
|
||||
(lambda (out v src-bstr src-start)
|
||||
(count-write-evt-via-write-out self out v src-bstr src-start)))]
|
||||
[else #f])]
|
||||
[get-write-special-evt
|
||||
(and get-write-special-evt
|
||||
(lambda (out v)
|
||||
(get-write-special-evt self v)))])
|
||||
;; fields
|
||||
[name name]
|
||||
[offset init-offset]
|
||||
[evt evt]
|
||||
[data data]
|
||||
[self self]))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
"pipe.rkt"
|
||||
"commit-port.rkt")
|
||||
|
||||
(provide peek-via-read-input-port
|
||||
open-input-peek-via-read)
|
||||
(provide peek-via-read-input-port)
|
||||
|
||||
(class peek-via-read-input-port #:extends commit-input-port
|
||||
(field
|
||||
|
|
@ -231,169 +230,3 @@
|
|||
[close
|
||||
(lambda ()
|
||||
(close-peek-buffer))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (open-input-peek-via-read #:name name
|
||||
#:self next-self
|
||||
#:data [data #f]
|
||||
#:read-in read-in
|
||||
#:read-is-atomic? [read-is-atomic? #f] ; => can implement progress evts
|
||||
#:close close
|
||||
#:get-location [get-location #f]
|
||||
#:count-lines! [count-lines! #f]
|
||||
#:init-offset [init-offset 0]
|
||||
#:file-position [file-position #f]
|
||||
#:alt-buffer-mode [alt-buffer-mode #f])
|
||||
(define-values (peek-pipe-i peek-pipe-o) (make-pipe))
|
||||
(define peeked-eof? #f)
|
||||
(define buf (make-bytes 4096))
|
||||
(define buffer-mode 'block)
|
||||
|
||||
;; in atomic mode
|
||||
(define (prepare-change self)
|
||||
(send core-input-port peek-pipe-i prepare-change))
|
||||
|
||||
;; in atomic mode
|
||||
(define (pull-some-bytes [amt (if (eq? 'block buffer-mode) (bytes-length buf) 1)] #:keep-eof? [keep-eof? #t])
|
||||
(define v (read-in next-self buf 0 amt #f))
|
||||
(cond
|
||||
[(eof-object? v)
|
||||
(when keep-eof?
|
||||
(set! peeked-eof? #t))
|
||||
eof]
|
||||
[(evt? v) v]
|
||||
[(eqv? v 0) 0]
|
||||
[else
|
||||
(let loop ([wrote 0])
|
||||
(define just-wrote (send core-output-port peek-pipe-o write-out buf wrote v #t #f #f))
|
||||
(define next-wrote (+ wrote just-wrote))
|
||||
(unless (= v next-wrote)
|
||||
(loop next-wrote)))
|
||||
v]))
|
||||
|
||||
(define (retry-pull? v)
|
||||
(and (integer? v) (not (eqv? v 0))))
|
||||
|
||||
;; in atomic mode
|
||||
(define (do-read-in self dest-bstr start end copy?)
|
||||
(let try-again ()
|
||||
(cond
|
||||
[(positive? (pipe-content-length peek-pipe-i))
|
||||
(send core-input-port peek-pipe-i read-in dest-bstr start end copy?)]
|
||||
[peeked-eof?
|
||||
(set! peeked-eof? #f)
|
||||
;; an EOF doesn't count as progress
|
||||
eof]
|
||||
[else
|
||||
(cond
|
||||
[(and (< (- end start) (bytes-length buf))
|
||||
(eq? 'block buffer-mode))
|
||||
(define v (pull-some-bytes))
|
||||
(cond
|
||||
[(or (eqv? v 0) (evt? v)) v]
|
||||
[else (try-again)])]
|
||||
[else
|
||||
(define v (read-in next-self dest-bstr start end copy?))
|
||||
(unless (eq? v 0)
|
||||
(progress!))
|
||||
v])])))
|
||||
|
||||
;; in atomic mode
|
||||
(define (do-peek-in self dest-bstr start end skip progress-evt copy?)
|
||||
(let try-again ()
|
||||
(define peeked-amt (if peek-pipe-i
|
||||
(pipe-content-length peek-pipe-i)
|
||||
0))
|
||||
(cond
|
||||
[(and progress-evt
|
||||
(sync/timeout 0 progress-evt))
|
||||
#f]
|
||||
[(and peek-pipe-i
|
||||
(peeked-amt . > . skip))
|
||||
(send core-input-port peek-pipe-i peek-in dest-bstr start end skip progress-evt copy?)]
|
||||
[peeked-eof?
|
||||
eof]
|
||||
[else
|
||||
(define v (pull-some-bytes))
|
||||
(if (retry-pull? v)
|
||||
(try-again)
|
||||
v)])))
|
||||
|
||||
;; in atomic mode
|
||||
(define (do-byte-ready self work-done!)
|
||||
(cond
|
||||
[(positive? (pipe-content-length peek-pipe-i))
|
||||
#t]
|
||||
[peeked-eof?
|
||||
#t]
|
||||
[else
|
||||
(define v (pull-some-bytes))
|
||||
(work-done!)
|
||||
(cond
|
||||
[(retry-pull? v)
|
||||
(do-byte-ready self void)]
|
||||
[(evt? v) v]
|
||||
[else
|
||||
(not (eqv? v 0))])]))
|
||||
|
||||
;; in atomic mode
|
||||
(define (purge-buffer)
|
||||
(set!-values (peek-pipe-i peek-pipe-o) (make-pipe))
|
||||
(set! peeked-eof? #f))
|
||||
|
||||
;; in atomic mode
|
||||
(define (get-progress-evt self)
|
||||
(send core-input-port peek-pipe-i get-progress-evt))
|
||||
|
||||
;; in atomic mode
|
||||
(define (progress!)
|
||||
;; Relies on support for `0 #f #f` arguments in pipe implementation:
|
||||
(send core-input-port peek-pipe-i commit 0 #f #f void))
|
||||
|
||||
(define (commit self amt evt ext-evt finish)
|
||||
(send core-input-port peek-pipe-i commit amt evt ext-evt finish))
|
||||
|
||||
(define do-buffer-mode
|
||||
(case-lambda
|
||||
[(self) buffer-mode]
|
||||
[(self mode) (set! buffer-mode mode)]))
|
||||
|
||||
(values (make-core-input-port
|
||||
#:name name
|
||||
#:data data
|
||||
#:self #f
|
||||
|
||||
#:prepare-change prepare-change
|
||||
|
||||
#:read-in do-read-in
|
||||
#:peek-in do-peek-in
|
||||
#:byte-ready do-byte-ready
|
||||
|
||||
#:get-progress-evt (and read-is-atomic?
|
||||
get-progress-evt)
|
||||
#:commit commit
|
||||
|
||||
#:close (lambda (self)
|
||||
(close next-self)
|
||||
(purge-buffer))
|
||||
|
||||
#:get-location (and get-location
|
||||
(lambda (self) (get-location next-self)))
|
||||
#:count-lines! (and count-lines!
|
||||
(lambda (self) (count-lines! next-self)))
|
||||
#:init-offset init-offset
|
||||
#:file-position (and file-position
|
||||
(case-lambda
|
||||
[(self) (file-position next-self)]
|
||||
[(self pos) (file-position next-self pos)]))
|
||||
#:buffer-mode (or (and alt-buffer-mode
|
||||
(case-lambda
|
||||
[(self) (alt-buffer-mode next-self)]
|
||||
[(self mode) (alt-buffer-mode next-self mode)]))
|
||||
do-buffer-mode))
|
||||
|
||||
;; in atomic mode:
|
||||
(case-lambda
|
||||
[() (purge-buffer)]
|
||||
[(pos) (- pos (pipe-content-length peek-pipe-i))])))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(require "../port/string-output.rkt"
|
||||
"../port/bytes-output.rkt"
|
||||
"../port/port.rkt"
|
||||
"../port/output-port.rkt")
|
||||
"../port/max-output-port.rkt")
|
||||
|
||||
(provide write-string/max
|
||||
write-bytes/max
|
||||
|
|
@ -44,27 +44,8 @@
|
|||
'full])]))
|
||||
|
||||
(define (make-output-port/max o max-length)
|
||||
(make-core-output-port
|
||||
#:name (object-name o)
|
||||
#:data (lambda () max-length)
|
||||
#:self o
|
||||
#:evt o
|
||||
#:write-out
|
||||
(lambda (o src-bstr src-start src-end nonblock? enable-break? copy?)
|
||||
(cond
|
||||
[max-length
|
||||
(define len (- src-end src-start))
|
||||
(unless (eq? max-length 'full)
|
||||
(define write-len (min len max-length))
|
||||
(define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len)))
|
||||
(if (= max-length wrote-len)
|
||||
(set! max-length 'full)
|
||||
(set! max-length (- max-length wrote-len))))
|
||||
len]
|
||||
[else
|
||||
(write-bytes src-bstr o src-start src-end)]))
|
||||
#:close void))
|
||||
(make-max-output-port o max-length))
|
||||
|
||||
(define (output-port/max-max-length o max-length)
|
||||
(and max-length
|
||||
((core-port-data o))))
|
||||
(max-output-port-max-length o)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user