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
|
(provide prop:input-port
|
||||||
input-port?
|
input-port?
|
||||||
->core-input-port
|
->core-input-port
|
||||||
(struct-out core-input-port)
|
(struct-out core-input-port))
|
||||||
make-core-input-port
|
|
||||||
compat-input-port-self)
|
|
||||||
|
|
||||||
(define-values (prop:input-port input-port-via-property? input-port-ref)
|
(define-values (prop:input-port input-port-via-property? input-port-ref)
|
||||||
(make-struct-type-property 'input-port
|
(make-struct-type-property 'input-port
|
||||||
|
|
@ -147,67 +145,3 @@
|
||||||
(define empty-input-port
|
(define empty-input-port
|
||||||
(new core-input-port
|
(new core-input-port
|
||||||
[name 'empty]))
|
[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?
|
output-port?
|
||||||
->core-output-port
|
->core-output-port
|
||||||
(struct-out core-output-port)
|
(struct-out core-output-port)
|
||||||
get-write-evt-via-write-out
|
get-write-evt-via-write-out)
|
||||||
make-core-output-port
|
|
||||||
compat-output-port-self)
|
|
||||||
|
|
||||||
(define-values (prop:output-port output-port-via-property? output-port-ref)
|
(define-values (prop:output-port output-port-via-property? output-port-ref)
|
||||||
(make-struct-type-property 'output-port
|
(make-struct-type-property 'output-port
|
||||||
|
|
@ -120,71 +118,3 @@
|
||||||
(define empty-output-port
|
(define empty-output-port
|
||||||
(new core-output-port
|
(new core-output-port
|
||||||
[name 'empty]))
|
[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"
|
"pipe.rkt"
|
||||||
"commit-port.rkt")
|
"commit-port.rkt")
|
||||||
|
|
||||||
(provide peek-via-read-input-port
|
(provide peek-via-read-input-port)
|
||||||
open-input-peek-via-read)
|
|
||||||
|
|
||||||
(class peek-via-read-input-port #:extends commit-input-port
|
(class peek-via-read-input-port #:extends commit-input-port
|
||||||
(field
|
(field
|
||||||
|
|
@ -231,169 +230,3 @@
|
||||||
[close
|
[close
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(close-peek-buffer))]))
|
(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"
|
(require "../port/string-output.rkt"
|
||||||
"../port/bytes-output.rkt"
|
"../port/bytes-output.rkt"
|
||||||
"../port/port.rkt"
|
"../port/port.rkt"
|
||||||
"../port/output-port.rkt")
|
"../port/max-output-port.rkt")
|
||||||
|
|
||||||
(provide write-string/max
|
(provide write-string/max
|
||||||
write-bytes/max
|
write-bytes/max
|
||||||
|
|
@ -44,27 +44,8 @@
|
||||||
'full])]))
|
'full])]))
|
||||||
|
|
||||||
(define (make-output-port/max o max-length)
|
(define (make-output-port/max o max-length)
|
||||||
(make-core-output-port
|
(make-max-output-port o max-length))
|
||||||
#: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))
|
|
||||||
|
|
||||||
(define (output-port/max-max-length o max-length)
|
(define (output-port/max-max-length o max-length)
|
||||||
(and max-length
|
(and max-length
|
||||||
((core-port-data o))))
|
(max-output-port-max-length o)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user