io: start conversion to classes
Change the internal port representation to an object-with-vtable representation. The syntax looks similar to the class system of `racket/class`, but everything is first-order: no class values, no mixins, etc. Also, the vtable can contain non-procedures (like #f for "not supported" or a port to mean a direcirection). Using objects will make port instaces smaller and support a reorganization to eliminate ad hoc `data`-field extensions. It will also replace a half-step was was in place for byte input Along with the conversion, change the way the fast path for writing works: When possible, expose a shared buffer and index into that buffer. Only byte string input ports are really converted, so far. A compatibility layer maps the old protocol to the new one, so conversion can continue piecewise.
This commit is contained in:
Matthew Flatt
parent
f8a130851f
commit
d8521e8486
405
racket/src/io/common/class.rkt
Normal file
405
racket/src/io/common/class.rkt
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/struct-info)
|
||||
racket/stxparam)
|
||||
|
||||
;; A class system that is somewhat similar to `racket/class`, but
|
||||
;; completely first order, with its structure nature exposed, and
|
||||
;; where the notion of "method" is flexible to allow non-procedures in
|
||||
;; the vtable.
|
||||
;;
|
||||
;; <class-defn> = (class <class-id> <clause> ...)
|
||||
;; | (class <class-id> #:extends <class-id> <clause> ...)
|
||||
;; <clause> = (field [<field-id> <duplicatable-init-expr>] ...)
|
||||
;; | (public [<method-id> <method>] ...)
|
||||
;; | (private [<method-id> <method>] ...)
|
||||
;; | (override [<method-id> <method>] ...)
|
||||
;; | (property [<property-expr> <val-expr>] ...)
|
||||
;; <method> = #f
|
||||
;; | (lambda (<id> ...) <expr> ...+)
|
||||
;; | (case-lambda [(<id> ...) <expr> ...+] ...)
|
||||
;; | <expr> ; must have explicit `self`, etc.
|
||||
;;
|
||||
;; A <class-id> and its <field>s behave as if they are in
|
||||
;; a `struct` declaration where `create-<class-id>` is the
|
||||
;; constructor, but an extra `vtable` field is added to
|
||||
;; the start of a class's structure if it has no superclass.
|
||||
;; The `#:authentic` option is added implicitly.
|
||||
;;
|
||||
;; Normally, use
|
||||
;; (new <class-id> [<field-id> <expr] ...)
|
||||
;; to create an instance of the class, where each unmentioned
|
||||
;; <field-id> gets its default value. To override methods for just
|
||||
;; this object, use
|
||||
;; (new <class-id> #:override ([<method-id> <method>] ...)
|
||||
;; [<field-id> <expr] ...)
|
||||
;; but beware that it involves allocating a new vtable each
|
||||
;; time the `new` expression is evaluated.
|
||||
;;
|
||||
;; Use
|
||||
;; (send <class-id> <obj-expr> <method-id> <arg-expr> ...)
|
||||
;; to call a method, or
|
||||
;; (mewthod <class-id> <obj-expr> <method-id>)
|
||||
;; to get a method that expects the object as its first argument.
|
||||
;;
|
||||
;; In a method, fields can be accessed directly by name, and `this` is
|
||||
;; bound to the current object.
|
||||
|
||||
(provide class
|
||||
this
|
||||
new
|
||||
send
|
||||
method)
|
||||
|
||||
(define-syntax-parameter this
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "illegal use outside of a method" stx)))
|
||||
|
||||
(begin-for-syntax
|
||||
(struct class-info (struct-info methods-id vtable-id vtable-accessor-id fields methods)
|
||||
#:property prop:struct-info (lambda (ci)
|
||||
(class-info-struct-info ci))))
|
||||
|
||||
(define-syntax (class stx)
|
||||
(define id (syntax-case stx ()
|
||||
[(_ id . _) #'id]))
|
||||
(define super-id (syntax-case stx ()
|
||||
[(_ id #:extends super-id . _)
|
||||
#'super-id]
|
||||
[_ #f]))
|
||||
(define super-ci (and super-id
|
||||
(syntax-local-value super-id)))
|
||||
(define (combine-ids ctx . elems)
|
||||
(datum->syntax ctx (string->symbol (apply string-append
|
||||
(for/list ([elem (in-list elems)])
|
||||
(if (string? elem)
|
||||
elem
|
||||
(symbol->string (syntax-e elem))))))))
|
||||
(define methods-id (combine-ids #'here id "-methods"))
|
||||
(define (add-procs base-id l what #:can-immutable? [can-immutable? #f])
|
||||
(for/list ([e (in-list l)])
|
||||
(syntax-case e ()
|
||||
[(id expr #:immutable)
|
||||
can-immutable?
|
||||
(list #'id #'expr (combine-ids base-id base-id "-" #'id) #f)]
|
||||
[(id expr)
|
||||
(list #'id #'expr (combine-ids base-id base-id "-" #'id) (combine-ids #'id "set-" base-id "-" #'id "!"))]
|
||||
[_ (raise-syntax-error #f (format "bad ~a clause" what) stx e)])))
|
||||
(define-values (new-fields new-methods override-methods locals properties)
|
||||
(let ([l-stx (syntax-case stx ()
|
||||
[(_ _ #:extends _ . rest) #'rest]
|
||||
[(_ _ . rest) #'rest])])
|
||||
(let loop ([l-stx l-stx] [new-fields null] [new-methods null] [override-methods null] [locals null] [properties null])
|
||||
(syntax-case l-stx (field public override private property)
|
||||
[() (values new-fields new-methods override-methods locals properties)]
|
||||
[((field fld ...) . rest)
|
||||
(loop #'rest
|
||||
(add-procs id (syntax->list #'(fld ...)) "field" #:can-immutable? #t)
|
||||
new-methods
|
||||
override-methods
|
||||
locals
|
||||
properties)]
|
||||
[((public method ...) . rest)
|
||||
(loop #'rest
|
||||
new-fields
|
||||
(add-procs methods-id (syntax->list #'(method ...)) "public")
|
||||
override-methods
|
||||
locals
|
||||
properties)]
|
||||
[((override method ...) . rest)
|
||||
(loop #'rest new-fields new-methods (syntax->list #'(method ...)) locals properties)]
|
||||
[((private method ...) . rest)
|
||||
(loop #'rest new-fields new-methods override-methods (syntax->list #'(method ...)) properties)]
|
||||
[((property prop ...) . rest)
|
||||
(loop #'rest new-fields new-methods override-methods locals (syntax->list #'((#:property . prop) ...)))]
|
||||
[(other . _)
|
||||
(raise-syntax-error #f "unrecognized" stx #'other)]))))
|
||||
(define all-fields (if super-ci
|
||||
(append (class-info-fields super-ci) new-fields)
|
||||
new-fields))
|
||||
(for ([override (in-list override-methods)])
|
||||
(syntax-case override ()
|
||||
[(method-id _) (check-member stx #'method-id (if super-ci (class-info-methods super-ci) null) "method")]
|
||||
[_ (raise-syntax-error #f "bad override clause" stx override)]))
|
||||
(with-syntax ([((field-id field-init-expr field-accessor-id field-mutator-maybe-id) ...) all-fields])
|
||||
(define wrapped-new-methods
|
||||
(for/list ([new-method (in-list new-methods)])
|
||||
(syntax-case new-method ()
|
||||
[(method-id method-init-expr . rest)
|
||||
#'(method-id (let ([method-id
|
||||
(bind-fields-in-body
|
||||
([field-id field-accessor-id field-mutator-maybe-id] ...)
|
||||
method-init-expr)])
|
||||
method-id)
|
||||
. rest)])))
|
||||
(define all-methods/vtable (if super-ci
|
||||
(append (for/list ([method (in-list (class-info-methods super-ci))])
|
||||
(syntax-case method ()
|
||||
[(method-id method-init-expr . rest)
|
||||
(or (for/or ([override (in-list override-methods)])
|
||||
(syntax-case override ()
|
||||
[(override-id override-init-expr . _)
|
||||
(and (eq? (syntax-e #'method-id) (syntax-e #'override-id))
|
||||
(list* #'method-id
|
||||
#'(let ([method-id
|
||||
(bind-fields-in-body
|
||||
([field-id field-accessor-id field-mutator-maybe-id] ...)
|
||||
override-init-expr)])
|
||||
method-id)
|
||||
#'rest))]))
|
||||
method)]))
|
||||
wrapped-new-methods)
|
||||
wrapped-new-methods))
|
||||
(define vtable-id (combine-ids #'here id "-vtable"))
|
||||
(define all-methods/next (for/list ([method (in-list all-methods/vtable)])
|
||||
(syntax-case method ()
|
||||
[(method-id method-init-expr method-accessor-id . _)
|
||||
(with-syntax ([vtable-id vtable-id])
|
||||
(list #'method-id
|
||||
#'(method-accessor-id vtable-id)
|
||||
#'method-accessor-id))])))
|
||||
(with-syntax ([id id]
|
||||
[(super-ids ...) (if super-id
|
||||
(list super-id)
|
||||
null)]
|
||||
[quoted-super-id (and super-id #`(quote-syntax #,super-id))]
|
||||
[(vtable-ids ...) (if super-id
|
||||
null
|
||||
(list (datum->syntax id 'vtable)))]
|
||||
[vtable-accessor-id (if super-ci
|
||||
(class-info-vtable-accessor-id super-ci)
|
||||
(combine-ids id id "-vtable"))]
|
||||
[vtable-id vtable-id]
|
||||
[struct:id (combine-ids id "struct:" id)]
|
||||
[make-id (combine-ids id "create-" id)]
|
||||
[id? (combine-ids id id "?")]
|
||||
[methods-id methods-id]
|
||||
[(super-methods-ids ...) (if super-ci
|
||||
(list (class-info-methods-id super-ci))
|
||||
null)]
|
||||
[(new-field-id/annotated ...) (for/list ([new-field (in-list new-fields)])
|
||||
(syntax-case new-field ()
|
||||
[(id _ _ #f) #'id]
|
||||
[(id . _) #'[id #:mutable]]))]
|
||||
[((new-method-id . _) ...) new-methods]
|
||||
[((_ _ rev-field-accessor-id . _) ...) (reverse all-fields)]
|
||||
[((_ _ _ rev-field-mutator-maybe-id) ...) (reverse all-fields)]
|
||||
[((method-id method-init-expr/vtable . _) ...) all-methods/vtable]
|
||||
[((_ method-init-expr/next method-accessor-id) ...) all-methods/next]
|
||||
[((local-id local-expr) ...) locals]
|
||||
[(local-tmp-id ...) (generate-temporaries locals)]
|
||||
[((propss ...) ...) properties])
|
||||
#`(begin
|
||||
(struct id super-ids ... (vtable-ids ... new-field-id/annotated ...)
|
||||
#:omit-define-syntaxes
|
||||
#:constructor-name make-id
|
||||
#:authentic
|
||||
propss ... ...)
|
||||
(struct methods-id super-methods-ids ... (new-method-id ...))
|
||||
(define vtable-id (methods-id method-init-expr/vtable ...))
|
||||
(begin
|
||||
(define local-tmp-id (let ([local-id
|
||||
(bind-fields-in-body ([field-id field-accessor-id field-mutator-maybe-id] ...)
|
||||
local-expr)])
|
||||
local-id))
|
||||
(define-syntax (local-id stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg (... ...))
|
||||
(with-syntax ([this-id (datum->syntax #'here 'this stx)])
|
||||
(syntax/loc stx (local-tmp-id this-id arg (... ...))))])))
|
||||
...
|
||||
(define-syntax id
|
||||
(class-info (list (quote-syntax struct:id)
|
||||
(quote-syntax make-id)
|
||||
(quote-syntax id?)
|
||||
(list (quote-syntax rev-field-accessor-id) ... (quote-syntax vtable-accessor-id))
|
||||
(list (maybe-quote-syntax rev-field-mutator-maybe-id) ... #f)
|
||||
quoted-super-id)
|
||||
(quote-syntax methods-id)
|
||||
(quote-syntax vtable-id)
|
||||
(quote-syntax vtable-accessor-id)
|
||||
(list (list (quote-syntax field-id) (quote-syntax field-init-expr)
|
||||
(quote-syntax field-accessor-id) (maybe-quote-syntax field-mutator-maybe-id))
|
||||
...)
|
||||
(list (list (quote-syntax method-id) (quote-syntax method-init-expr/next)
|
||||
(quote-syntax method-accessor-id))
|
||||
...)))))))
|
||||
|
||||
(define-syntax (bind-fields-in-body stx)
|
||||
(syntax-case stx (lambda case-lambda)
|
||||
[(_ fields #f) #'#f]
|
||||
[(_ fields (form . rest))
|
||||
#'(bind-fields-in-body fields form (form . rest))]
|
||||
[(_ fields ctx (lambda (arg ...) body0 body ...))
|
||||
#'(bind-fields-in-body fields ctx (case-lambda [(arg ...) body0 body ...]))]
|
||||
[(_ fields ctx (case-lambda clause ...))
|
||||
(with-syntax ([(new-clause ...)
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))])
|
||||
(syntax-case clause ()
|
||||
[[(arg ...) body0 body ...]
|
||||
(with-syntax ([(arg-tmp ...) (generate-temporaries #'(arg ...))])
|
||||
#'[(this-id arg-tmp ...)
|
||||
(syntax-parameterize ([this (make-rename-transformer #'this-id)])
|
||||
(bind-fields
|
||||
fields
|
||||
this-id ctx
|
||||
(let-syntax ([arg (make-rename-transformer #'arg-tmp)] ...)
|
||||
body0 body ...)))])]))])
|
||||
(syntax/loc (syntax-case stx () [(_ _ _ rhs) #'rhs])
|
||||
(case-lambda new-clause ...)))]
|
||||
[(_ fields _ expr)
|
||||
#'expr]))
|
||||
|
||||
(define-syntax (bind-fields stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([field-id field-accessor-id field-mutator-maybe-id] ...) this-id ctx body)
|
||||
(with-syntax ([(field-id ...) (for/list ([field-id (in-list (syntax->list #'(field-id ...)))])
|
||||
(datum->syntax #'ctx (syntax-e field-id)))])
|
||||
#'(let-syntax ([field-id (make-set!-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ rhs) (if (syntax-e (quote-syntax field-mutator-maybe-id))
|
||||
(syntax/loc stx (field-mutator-maybe-id this-id rhs))
|
||||
(raise-syntax-error #f "field is immutable" stx))]
|
||||
[(_ arg (... ...)) (syntax/loc stx ((field-accessor-id this-id) arg (... ...)))]
|
||||
[else (syntax/loc stx (field-accessor-id this-id))])))]
|
||||
...)
|
||||
body))]))
|
||||
|
||||
(define-syntax (new stx)
|
||||
(syntax-case stx ()
|
||||
[(_ class-id #:override (override ...) init ...)
|
||||
(let ([ci (and (identifier? #'class-id)
|
||||
(syntax-local-value #'class-id (lambda () #f)))])
|
||||
(unless (class-info? ci)
|
||||
(raise-syntax-error #f "not a class identifier" stx #'class-id))
|
||||
(for ([init (in-list (syntax->list #'(init ...)))])
|
||||
(syntax-case init ()
|
||||
[(field-id _) (check-member stx #'field-id (class-info-fields ci) "field")]
|
||||
[_ (raise-syntax-error #f "bad field-inialization clause" stx init)]))
|
||||
(for ([override (in-list (syntax->list #'(override ...)))])
|
||||
(syntax-case override ()
|
||||
[(method-id _) (check-member stx #'method-id (class-info-methods ci) "method")]
|
||||
[_ (raise-syntax-error #f "bad method-override clause" stx override)]))
|
||||
(define field-exprs (for/list ([field (in-list (class-info-fields ci))])
|
||||
(syntax-case field ()
|
||||
[(field-id field-expr . _)
|
||||
(or (for/or ([init (in-list (syntax->list #'(init ...)))])
|
||||
(syntax-case init ()
|
||||
[(id expr)
|
||||
(and (eq? (syntax-e #'id) (syntax-e #'field-id))
|
||||
#'expr)]))
|
||||
#'field-expr)])))
|
||||
(define overrides (syntax->list #'(override ...)))
|
||||
(with-syntax ([make-id (cadr (class-info-struct-info ci))]
|
||||
[vtable-id (class-info-vtable-id ci)]
|
||||
[(field-expr ...) field-exprs])
|
||||
(cond
|
||||
[(null? overrides)
|
||||
(syntax/loc stx (make-id vtable-id field-expr ...))]
|
||||
[else
|
||||
(with-syntax ([methods-id (class-info-methods-id ci)]
|
||||
[(method-expr ...)
|
||||
(for/list ([method (in-list (class-info-methods ci))])
|
||||
(syntax-case method ()
|
||||
[(id _ selector-id . _)
|
||||
(or (for/or ([override (in-list overrides)])
|
||||
(syntax-case override ()
|
||||
[(override-id expr)
|
||||
(and (eq? (syntax-e #'override-id) (syntax-e #'id))
|
||||
(with-syntax ([((field-id _ field-accessor-id field-mutator-maybe-id) ...)
|
||||
(class-info-fields ci)])
|
||||
#'(bind-fields-in-body
|
||||
([field-id field-accessor-id field-mutator-maybe-id] ...)
|
||||
expr)))]))
|
||||
#'(selector-id vtable-id))]))])
|
||||
(syntax/loc stx (make-id (methods-id method-expr ...)
|
||||
field-expr ...)))])))]
|
||||
[(_ class-id init ...)
|
||||
(syntax/loc stx (new class-id #:override () init ...))]))
|
||||
|
||||
(define-for-syntax (send-or-method stx call?)
|
||||
(syntax-case stx ()
|
||||
[(_ class-id obj method-id arg ...)
|
||||
(let ([ci (and (identifier? #'class-id)
|
||||
(syntax-local-value #'class-id (lambda () #f)))])
|
||||
(unless (class-info? ci)
|
||||
(raise-syntax-error #f "not a class identifier" stx #'class-id))
|
||||
(define method-accessor-id
|
||||
(or (for/or ([method (in-list (class-info-methods ci))])
|
||||
(syntax-case method ()
|
||||
[(id _ accessor-id)
|
||||
(and (eq? (syntax-e #'id) (syntax-e #'method-id))
|
||||
#'accessor-id)]))
|
||||
(raise-syntax-error #f "cannot find method" stx #'method-id)))
|
||||
(with-syntax ([vtable-accessor-id (class-info-vtable-accessor-id ci)]
|
||||
[method-accessor-id method-accessor-id])
|
||||
(if call?
|
||||
#'(let ([o obj])
|
||||
((method-accessor-id (vtable-accessor-id o)) o arg ...))
|
||||
#'(method-accessor-id (vtable-accessor-id obj)))))]))
|
||||
|
||||
(define-syntax (send stx)
|
||||
(send-or-method stx #t))
|
||||
|
||||
;; Gets a method to be called as a procedure, where the call must
|
||||
;; include the "self" argument --- so, less safe than `send`, but
|
||||
;; allows external handling for a method that is #f.
|
||||
(define-syntax (method stx)
|
||||
(syntax-case stx ()
|
||||
[(_ class-id obj method-id)
|
||||
(send-or-method stx #f)]))
|
||||
|
||||
(define-for-syntax (check-member stx id l what)
|
||||
(or (for/or ([e (in-list l)])
|
||||
(syntax-case e ()
|
||||
[(e-id . _)
|
||||
(eq? (syntax-e #'e-id) (syntax-e id))]))
|
||||
(raise-syntax-error #f (format "no such ~a" what) stx id)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax maybe-quote-syntax
|
||||
(syntax-rules ()
|
||||
[(_ #f) #f]
|
||||
[(_ e) (quote-syntax e)])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(module+ test
|
||||
(class example
|
||||
(field
|
||||
[a 1 #:immutable]
|
||||
[b 2])
|
||||
(private
|
||||
[other (lambda (q) (list q this))])
|
||||
(public
|
||||
[q #f]
|
||||
[m (lambda (z) (list a (other b)))]
|
||||
[n (lambda (x y z) (vector a b x y z))]))
|
||||
|
||||
(class sub #:extends example
|
||||
(field
|
||||
[c 3]
|
||||
[d 4])
|
||||
(override
|
||||
[m (lambda (z) 'other)])
|
||||
(property
|
||||
[prop:custom-write (lambda (s o m)
|
||||
(write 'sub: o)
|
||||
(write (sub-d s) o))]))
|
||||
|
||||
(define ex (new example [b 5]))
|
||||
|
||||
(send example ex m 'ok)
|
||||
(method example ex m)
|
||||
(new sub [d 5])
|
||||
(send example (new sub) m 'more)
|
||||
(set-example-b! ex 6)
|
||||
|
||||
(define ex2 (new example
|
||||
#:override
|
||||
([q (lambda (x y z)
|
||||
(box (vector x y z a b)))])
|
||||
[b 'b]
|
||||
[a 'a]))
|
||||
(send example ex2 n 1 2 3))
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -16,11 +17,11 @@
|
|||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(raise-argument-error 'file-stream-buffer-mode "port?" p)])])
|
||||
(define buffer-mode (core-port-buffer-mode p))
|
||||
(define buffer-mode (method core-port p buffer-mode))
|
||||
(atomically
|
||||
(check-not-closed who p)
|
||||
(and buffer-mode
|
||||
(buffer-mode (core-port-self p)))))]
|
||||
(buffer-mode p))))]
|
||||
[(p mode)
|
||||
(unless (or (input-port? p) (output-port? p))
|
||||
(raise-argument-error who "port?" p))
|
||||
|
|
@ -33,10 +34,10 @@
|
|||
(define (set-buffer-mode p)
|
||||
(atomically
|
||||
(check-not-closed who p)
|
||||
(define buffer-mode (core-port-buffer-mode p))
|
||||
(define buffer-mode (method core-port p buffer-mode))
|
||||
(cond
|
||||
[buffer-mode
|
||||
(buffer-mode (core-port-self p) mode)
|
||||
(buffer-mode p mode)
|
||||
#t]
|
||||
[else #f])))
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -18,13 +18,10 @@
|
|||
peek-bytes!
|
||||
peek-bytes-avail!
|
||||
peek-bytes-avail!*
|
||||
peek-bytes-avail!/enable-break
|
||||
|
||||
do-read-byte/core-port)
|
||||
peek-bytes-avail!/enable-break)
|
||||
|
||||
(module+ internal
|
||||
(provide do-read-bytes!
|
||||
peek-byte/core-port))
|
||||
(provide do-read-bytes!))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -51,13 +48,7 @@
|
|||
|
||||
(define/who (read-byte [orig-in (current-input-port)])
|
||||
(let ([in (->core-input-port orig-in who)])
|
||||
(do-read-byte/core-port who in)))
|
||||
|
||||
(define (do-read-byte/core-port who in)
|
||||
(define read-byte (core-input-port-read-byte in))
|
||||
(cond
|
||||
[read-byte (do-read-byte who read-byte in)]
|
||||
[else (read-byte-via-bytes in #:special-ok? #f)]))
|
||||
(read-a-byte who in)))
|
||||
|
||||
(define/who (read-bytes amt [in (current-input-port)])
|
||||
(check who exact-nonnegative-integer? amt)
|
||||
|
|
@ -133,14 +124,7 @@
|
|||
(check who input-port? orig-in)
|
||||
(check who exact-nonnegative-integer? skip-k)
|
||||
(let ([in (->core-input-port orig-in)])
|
||||
(peek-byte/core-port in skip-k)))
|
||||
|
||||
(define/who (peek-byte/core-port in skip-k)
|
||||
(define peek-byte (and (zero? skip-k)
|
||||
(core-input-port-peek-byte in)))
|
||||
(cond
|
||||
[peek-byte (do-peek-byte who peek-byte in)]
|
||||
[else (peek-byte-via-bytes in skip-k #:special-ok? #f)]))
|
||||
(peek-a-byte who in skip-k)))
|
||||
|
||||
(define/who (peek-bytes amt skip-k [in (current-input-port)])
|
||||
(check who exact-nonnegative-integer? amt)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require racket/fixnum
|
||||
"../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"output-port.rkt"
|
||||
|
|
@ -77,15 +78,15 @@
|
|||
(let ([out (->core-output-port out)])
|
||||
(atomically
|
||||
(check-not-closed who out)
|
||||
(define get-write-evt (core-output-port-get-write-evt out))
|
||||
(define get-write-evt (method core-output-port out get-write-evt))
|
||||
(unless get-write-evt
|
||||
(end-atomic)
|
||||
(raise-arguments-error who
|
||||
"port does not support output events"
|
||||
"port" out))
|
||||
(get-write-evt (core-port-self out) out bstr start-pos end-pos))))
|
||||
(get-write-evt out bstr start-pos end-pos))))
|
||||
|
||||
(define/who (port-writes-atomic? out)
|
||||
(check who output-port? out)
|
||||
(let ([out (->core-output-port out)])
|
||||
(and (core-output-port-get-write-evt out) #t)))
|
||||
(and (method core-output-port out get-write-evt) #t)))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(require racket/fixnum
|
||||
"../common/check.rkt"
|
||||
"../common/fixnum.rkt"
|
||||
"../common/object.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -17,8 +17,6 @@
|
|||
get-output-bytes
|
||||
string-port?)
|
||||
|
||||
(struct input-bytes-data ())
|
||||
|
||||
(define/who (open-input-bytes bstr [name 'string])
|
||||
(check who bytes? bstr)
|
||||
(define p (make-input-bytes (bytes->immutable-bytes bstr) name))
|
||||
|
|
@ -26,144 +24,174 @@
|
|||
(port-count-lines! p))
|
||||
p)
|
||||
|
||||
(define-constructor (make-input-bytes bstr name)
|
||||
(define-fixnum i 0)
|
||||
(define alt-pos #f)
|
||||
(define len (bytes-length bstr))
|
||||
(class bytes-input-port #:extends core-input-port
|
||||
(field
|
||||
[progress-sema #f]
|
||||
[commit-manager #f]
|
||||
[bstr #f] ; normally installed as buffer
|
||||
[pos 0] ; used when bstr is not installed as buffer
|
||||
[alt-pos #f])
|
||||
|
||||
(define progress-sema #f)
|
||||
(define (progress!)
|
||||
(when progress-sema
|
||||
(semaphore-post progress-sema)
|
||||
(set! progress-sema #f)))
|
||||
(private
|
||||
;; in atomic mode
|
||||
[progress!
|
||||
(lambda ()
|
||||
(when progress-sema
|
||||
(semaphore-post progress-sema)
|
||||
(set! progress-sema #f)))]
|
||||
|
||||
(define commit-manager #f)
|
||||
;; in atomic mode [can leave atomic mode temporarily]
|
||||
;; After this function returns, complete any commit-changing work
|
||||
;; before leaving atomic mode again.
|
||||
[pause-waiting-commit
|
||||
(lambda ()
|
||||
(when commit-manager
|
||||
(commit-manager-pause commit-manager)))]
|
||||
|
||||
;; in atomic mode [can leave atomic mode temporarily]
|
||||
;; After this function returns, complete any commit-changing work
|
||||
;; before leaving atomic mode again.
|
||||
(define (pause-waiting-commit)
|
||||
(when commit-manager
|
||||
(commit-manager-pause commit-manager)))
|
||||
;; in atomic mode [can leave atomic mode temporarily]
|
||||
(define (wait-commit progress-evt ext-evt finish)
|
||||
(cond
|
||||
[(and (not commit-manager)
|
||||
;; Try shortcut:
|
||||
(not (sync/timeout 0 progress-evt))
|
||||
(sync/timeout 0 ext-evt))
|
||||
(finish)
|
||||
#t]
|
||||
[else
|
||||
;; General case to support blocking and potentially multiple
|
||||
;; commiting threads:
|
||||
(unless commit-manager
|
||||
(set! commit-manager (make-commit-manager)))
|
||||
(commit-manager-wait commit-manager progress-evt ext-evt finish)]))
|
||||
;; in atomic mode [can leave atomic mode temporarily]
|
||||
[wait-commit
|
||||
(lambda (progress-evt ext-evt finish)
|
||||
(cond
|
||||
[(and (not commit-manager)
|
||||
;; Try shortcut:
|
||||
(not (sync/timeout 0 progress-evt))
|
||||
(sync/timeout 0 ext-evt))
|
||||
(finish)
|
||||
#t]
|
||||
[else
|
||||
;; General case to support blocking and potentially multiple
|
||||
;; commiting threads:
|
||||
(unless commit-manager
|
||||
(set! commit-manager (make-commit-manager)))
|
||||
(commit-manager-wait commit-manager progress-evt ext-evt finish)]))]
|
||||
|
||||
(make-core-input-port
|
||||
#:name name
|
||||
#:data (input-bytes-data)
|
||||
#:self self
|
||||
;; in atomic mode
|
||||
[in-buffer-pos
|
||||
(lambda ()
|
||||
(if buffer
|
||||
buffer-pos
|
||||
pos))])
|
||||
|
||||
#:prepare-change
|
||||
(method
|
||||
(lambda ()
|
||||
(pause-waiting-commit)))
|
||||
(override
|
||||
[close
|
||||
(lambda ()
|
||||
(set! commit-manager #f) ; to indicate closed
|
||||
(progress!)
|
||||
(set! bstr #f)
|
||||
(when buffer
|
||||
(set! offset buffer-pos)
|
||||
(set! buffer #f)))]
|
||||
[file-position
|
||||
(case-lambda
|
||||
[() (or alt-pos (in-buffer-pos))]
|
||||
[(given-pos)
|
||||
(define len buffer-end)
|
||||
(define new-pos (if (eof-object? given-pos)
|
||||
len
|
||||
(min len given-pos)))
|
||||
(if buffer
|
||||
(set! buffer-pos new-pos)
|
||||
(set! pos new-pos))
|
||||
(set! alt-pos (and (not (eof-object? given-pos))
|
||||
(given-pos . > . new-pos)
|
||||
given-pos))])]
|
||||
|
||||
#:read-byte
|
||||
(method
|
||||
(lambda ()
|
||||
(let ([pos i])
|
||||
(if (pos . fx< . len)
|
||||
(begin
|
||||
(set! i (fx+ pos 1))
|
||||
(progress!)
|
||||
(bytes-ref bstr pos))
|
||||
eof))))
|
||||
[prepare-change
|
||||
(lambda ()
|
||||
(pause-waiting-commit))]
|
||||
|
||||
#:read-in
|
||||
(method
|
||||
(lambda (dest-bstr start end copy?)
|
||||
(define pos i)
|
||||
(cond
|
||||
[(pos . < . len)
|
||||
(define amt (min (- end start) (- len pos)))
|
||||
(set! i (+ pos amt))
|
||||
(bytes-copy! dest-bstr start bstr pos (+ pos amt))
|
||||
(progress!)
|
||||
amt]
|
||||
[else eof])))
|
||||
[read-in
|
||||
(lambda (dest-bstr start end copy?)
|
||||
(define len buffer-end)
|
||||
(define i (in-buffer-pos))
|
||||
(cond
|
||||
[(i . < . len)
|
||||
(define amt (min (- end start) (fx- len i)))
|
||||
(define new-pos (fx+ i amt))
|
||||
(cond
|
||||
[(not count)
|
||||
;; Keep/resume fast mode
|
||||
(set! buffer-pos new-pos)
|
||||
(set! offset 0)
|
||||
(set! buffer bstr)]
|
||||
[else
|
||||
(set! pos new-pos)])
|
||||
(bytes-copy! dest-bstr start bstr i new-pos)
|
||||
(progress!)
|
||||
amt]
|
||||
[else eof]))]
|
||||
|
||||
#:peek-byte
|
||||
(method
|
||||
(lambda ()
|
||||
(let ([pos i])
|
||||
(if (pos . < . len)
|
||||
(bytes-ref bstr pos)
|
||||
eof))))
|
||||
[peek-in
|
||||
(lambda (dest-bstr start end skip progress-evt copy?)
|
||||
(define i (in-buffer-pos))
|
||||
(define len buffer-end)
|
||||
(define at-pos (+ i skip))
|
||||
(cond
|
||||
[(and progress-evt (sync/timeout 0 progress-evt))
|
||||
#f]
|
||||
[(at-pos . < . len)
|
||||
(define amt (min (- end start) (fx- len at-pos)))
|
||||
(bytes-copy! dest-bstr start bstr at-pos (fx+ at-pos amt))
|
||||
amt]
|
||||
[else eof]))]
|
||||
|
||||
#:peek-in
|
||||
(method
|
||||
(lambda (dest-bstr start end skip progress-evt copy?)
|
||||
(define pos (+ i skip))
|
||||
(cond
|
||||
[(and progress-evt (sync/timeout 0 progress-evt))
|
||||
#f]
|
||||
[(pos . < . len)
|
||||
(define amt (min (- end start) (- len pos)))
|
||||
(bytes-copy! dest-bstr start bstr pos (+ pos amt))
|
||||
amt]
|
||||
[else eof])))
|
||||
[byte-ready
|
||||
(lambda (work-done!)
|
||||
((in-buffer-pos) . < . buffer-end))]
|
||||
|
||||
[get-progress-evt
|
||||
(lambda ()
|
||||
(define new-sema
|
||||
(or progress-sema
|
||||
(let ([sema (make-semaphore)])
|
||||
(set! progress-sema sema)
|
||||
;; set port to slow mode:
|
||||
(when buffer
|
||||
(define i buffer-pos)
|
||||
(set! pos i)
|
||||
(set! offset i)
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end))
|
||||
sema)))
|
||||
(semaphore-peek-evt new-sema))]
|
||||
|
||||
#:byte-ready
|
||||
(method
|
||||
(lambda (work-done!)
|
||||
(i . < . len)))
|
||||
[commit
|
||||
(lambda (amt progress-evt ext-evt finish)
|
||||
(wait-commit
|
||||
progress-evt ext-evt
|
||||
;; in atomic mode, maybe in a different thread:
|
||||
(lambda ()
|
||||
(define len buffer-end)
|
||||
(define i (in-buffer-pos))
|
||||
(let ([amt (min amt (- len i))])
|
||||
(define dest-bstr (make-bytes amt))
|
||||
(bytes-copy! dest-bstr 0 bstr i (+ i amt))
|
||||
(cond
|
||||
[(not count)
|
||||
;; Keep/resume fast mode
|
||||
(set! buffer-pos (fx+ i amt))
|
||||
(set! buffer bstr)
|
||||
(set! offset 0)]
|
||||
[else
|
||||
(set! pos (fx+ i amt))])
|
||||
(progress!)
|
||||
(finish dest-bstr)))))]
|
||||
|
||||
#:close
|
||||
(method
|
||||
(lambda ()
|
||||
(set! commit-manager #f) ; to indicate closed
|
||||
(progress!)))
|
||||
[count-lines!
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(define i buffer-pos)
|
||||
(set! offset i)
|
||||
(set! pos i)
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end)))]))
|
||||
|
||||
#:get-progress-evt
|
||||
(method
|
||||
(lambda ()
|
||||
(unless progress-sema
|
||||
(set! progress-sema (make-semaphore)))
|
||||
(semaphore-peek-evt progress-sema)))
|
||||
|
||||
#:commit
|
||||
(method
|
||||
(lambda (amt progress-evt ext-evt finish)
|
||||
(unless commit-manager
|
||||
(set! commit-manager (make-commit-manager)))
|
||||
(commit-manager-wait
|
||||
commit-manager
|
||||
progress-evt ext-evt
|
||||
;; in atomic mode, maybe in a different thread:
|
||||
(lambda ()
|
||||
(let ([amt (min amt (- len i))])
|
||||
(define dest-bstr (make-bytes amt))
|
||||
(bytes-copy! dest-bstr 0 bstr i (+ i amt))
|
||||
(set! i (+ i amt))
|
||||
(progress!)
|
||||
(finish dest-bstr))))))
|
||||
|
||||
#:file-position
|
||||
(method
|
||||
(case-lambda
|
||||
[() (or alt-pos i)]
|
||||
[(new-pos)
|
||||
(set! i (if (eof-object? new-pos)
|
||||
len
|
||||
(min len new-pos)))
|
||||
(set! alt-pos
|
||||
(and new-pos
|
||||
(not (eof-object? new-pos))
|
||||
(new-pos . > . i)
|
||||
new-pos))]))))
|
||||
(define (make-input-bytes bstr name)
|
||||
(new bytes-input-port
|
||||
[name name]
|
||||
[buffer bstr]
|
||||
[buffer-end (bytes-length bstr)]
|
||||
[bstr bstr]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -183,20 +211,20 @@
|
|||
#:evt o
|
||||
#:write-out
|
||||
(lambda (o src-bstr src-start src-end nonblock? enable-break? copy?)
|
||||
((core-output-port-write-out o) (core-port-self o) src-bstr src-start src-end nonblock? enable-break? copy?))
|
||||
(send core-output-port o write-out src-bstr src-start src-end nonblock? enable-break? copy?))
|
||||
#:close
|
||||
(lambda (o) ((core-port-close o) (core-port-self o)))
|
||||
(lambda (o) (send core-port o close))
|
||||
#:get-write-evt
|
||||
(and (core-output-port-get-write-evt o)
|
||||
(and (method core-output-port o get-write-evt)
|
||||
(lambda (o orig-o bstr start-k end-k)
|
||||
((core-output-port-get-write-evt o) (core-port-self o) o bstr start-k end-k)))
|
||||
(send core-output-port o get-write-evt bstr start-k end-k)))
|
||||
#:get-location
|
||||
(and (core-port-get-location o)
|
||||
(lambda (o) ((core-port-get-location o) (core-port-self o))))
|
||||
(and (method core-port o get-location)
|
||||
(lambda (o) (send core-port o get-location)))
|
||||
#:count-lines!
|
||||
(and (core-port-count-lines! o)
|
||||
(and (method core-port o count-lines!)
|
||||
(lambda (o)
|
||||
((core-port-count-lines! o) (core-port-self o))))
|
||||
(send core-port o count-lines!)))
|
||||
#:file-position
|
||||
(case-lambda
|
||||
[(o) (pipe-write-position o)]
|
||||
|
|
@ -215,7 +243,7 @@
|
|||
"position" new-pos))
|
||||
(pipe-write-position o len)
|
||||
(define amt (- new-pos len))
|
||||
((core-output-port-write-out o) (core-port-self o) (make-bytes amt 0) 0 amt #f #f #f)
|
||||
(send core-output-port o write-out (make-bytes amt 0) 0 amt #f #f #f)
|
||||
(void)]
|
||||
[else
|
||||
(pipe-write-position o new-pos)])])))
|
||||
|
|
@ -253,7 +281,7 @@
|
|||
(cond
|
||||
[(input-port? p)
|
||||
(let ([p (->core-input-port p)])
|
||||
(input-bytes-data? (core-port-data p)))]
|
||||
(bytes-input-port? p))]
|
||||
[(output-port? p)
|
||||
(let ([p (->core-output-port p)])
|
||||
(output-bytes-data? (core-port-data p)))]
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
;; that is prefixed when a port-closed check normally needs
|
||||
;; to happen atomically with respect to the check.
|
||||
(define (check-not-closed who cp)
|
||||
(when (closed-state-closed? (core-port-closed cp))
|
||||
(when (core-port-closed? cp)
|
||||
(end-atomic)
|
||||
(define input? (core-input-port? cp))
|
||||
(raise-arguments-error who
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -19,21 +20,20 @@
|
|||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(raise-argument-error 'close-input-port "port?" p)])])
|
||||
(closed-state-closed? (core-port-closed p))))
|
||||
(core-port-closed? p)))
|
||||
|
||||
;; maybe in atomic mode via custodian shutdown:
|
||||
(define (close-port p)
|
||||
(define closed (core-port-closed p))
|
||||
(unless (closed-state-closed? closed)
|
||||
(unless (core-port-closed? p)
|
||||
(atomically
|
||||
((core-port-close p) (core-port-self p))
|
||||
(set-closed-state! closed))))
|
||||
(send core-port p close)
|
||||
(set-closed-state! p))))
|
||||
|
||||
;; in atomic mode
|
||||
(define (set-closed-state! closed)
|
||||
(unless (closed-state-closed? closed)
|
||||
(set-closed-state-closed?! closed #t)
|
||||
(let ([s (closed-state-closed-sema closed)])
|
||||
(define (set-closed-state! p)
|
||||
(unless (core-port-closed? p)
|
||||
(set-core-port-closed?! p #t)
|
||||
(let ([s (core-port-closed-sema p)])
|
||||
(when s (semaphore-post s)))))
|
||||
|
||||
(define/who (close-input-port p)
|
||||
|
|
@ -50,13 +50,12 @@
|
|||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(raise-argument-error 'port-closed-evt "port?" p)])])
|
||||
(define closed (core-port-closed p))
|
||||
(define sema
|
||||
(atomically
|
||||
(or (closed-state-closed-sema closed)
|
||||
(or (core-port-closed-sema p)
|
||||
(let ([s (make-semaphore)])
|
||||
(set-closed-state-closed-sema! closed s)
|
||||
(when (closed-state-closed? closed)
|
||||
(set-core-port-closed-sema! p s)
|
||||
(when (core-port-closed? p)
|
||||
(semaphore-post s))
|
||||
s))))
|
||||
(define self (wrap-evt (semaphore-peek-evt sema)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -31,22 +32,20 @@
|
|||
[else (check who #:test #f #:contract "port?" p)])])
|
||||
(atomically
|
||||
(check-not-closed who p)
|
||||
(unless (core-port-count? p)
|
||||
(set-core-port-count?! p #t)
|
||||
(set-core-port-line! p 1)
|
||||
(set-core-port-column! p 0)
|
||||
(set-core-port-position! p (add1 (or (core-port-offset p) 0)))
|
||||
(define count-lines! (core-port-count-lines! p))
|
||||
(unless (core-port-count p)
|
||||
(set-core-port-count! p (location #f #f 1 0 (add1 (or (core-port-offset p) 0))))
|
||||
(define count-lines! (method core-port p count-lines!))
|
||||
(when count-lines!
|
||||
(count-lines! (core-port-self p)))))))
|
||||
(count-lines! p))))))
|
||||
|
||||
(define/who (port-counts-lines? p)
|
||||
(core-port-count?
|
||||
(cond
|
||||
[(input-port? p) (->core-input-port p)]
|
||||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(check who #:test #f #:contract "port?" p)])))
|
||||
(and (core-port-count
|
||||
(cond
|
||||
[(input-port? p) (->core-input-port p)]
|
||||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(check who #:test #f #:contract "port?" p)]))
|
||||
#t))
|
||||
|
||||
(define/who (port-next-location p)
|
||||
(let ([p (cond
|
||||
|
|
@ -54,23 +53,24 @@
|
|||
[(output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(check who #:test #f #:contract "port?" p)])])
|
||||
(define loc (core-port-count p))
|
||||
(cond
|
||||
[(core-port-count? p)
|
||||
[loc
|
||||
(atomically
|
||||
(check-not-closed who p)
|
||||
(define get-location (core-port-get-location p))
|
||||
(define get-location (method core-port p get-location))
|
||||
(cond
|
||||
[get-location
|
||||
(get-location (core-port-self p))]
|
||||
(get-location p)]
|
||||
[else
|
||||
(values (core-port-line p)
|
||||
(core-port-column p)
|
||||
(core-port-position p))]))]
|
||||
[(core-port-file-position p)
|
||||
(values (location-line loc)
|
||||
(location-column loc)
|
||||
(location-position loc))]))]
|
||||
[(method core-port p file-position)
|
||||
(define offset (do-simple-file-position who p (lambda () #f)))
|
||||
(values #f #f (and offset (add1 offset)))]
|
||||
[else
|
||||
(define offset (core-port-offset p))
|
||||
(define offset (get-core-port-offset p))
|
||||
(values #f #f (and offset (add1 offset)))])))
|
||||
|
||||
(define/who (set-port-next-location! p line col pos)
|
||||
|
|
@ -84,11 +84,11 @@
|
|||
[(input-port? p) (->core-input-port p)]
|
||||
[else (->core-output-port p)])])
|
||||
(atomically
|
||||
(when (and (core-port-count? p)
|
||||
(not (core-port-count-lines! p)))
|
||||
(set-core-port-line! p line)
|
||||
(set-core-port-column! p col)
|
||||
(set-core-port-position! p pos)))))
|
||||
(define loc (core-port-count p))
|
||||
(when (and loc (not (method core-port p get-location)))
|
||||
(set-location-line! loc line)
|
||||
(set-location-column! loc col)
|
||||
(set-location-position! loc pos)))))
|
||||
|
||||
;; in atomic mode
|
||||
;; When line counting is enabled, increment line, column, etc. counts
|
||||
|
|
@ -98,15 +98,16 @@
|
|||
;; can go backwards when the decoding completes.
|
||||
(define (port-count! in amt bstr start)
|
||||
(increment-offset! in amt)
|
||||
(when (core-port-count? in)
|
||||
(define loc (core-port-count in))
|
||||
(when loc
|
||||
(define end (+ start amt))
|
||||
(let loop ([i start]
|
||||
[span 0] ; number of previous bytes still to send to UTF-8 decoding
|
||||
[line (core-port-line in)]
|
||||
[column (core-port-column in)]
|
||||
[position (core-port-position in)]
|
||||
[state (core-port-state in)]
|
||||
[cr-state (core-port-cr-state in)]) ; #t => previous char was #\return
|
||||
[line (location-line loc)]
|
||||
[column (location-column loc)]
|
||||
[position (location-position loc)]
|
||||
[state (location-state loc)]
|
||||
[cr-state (location-cr-state loc)]) ; #t => previous char was #\return
|
||||
(define (finish-utf-8 i abort-mode)
|
||||
(define-values (used-bytes got-chars new-state)
|
||||
(utf-8-decode! bstr (- i span) i
|
||||
|
|
@ -133,11 +134,11 @@
|
|||
[(= i end)
|
||||
(cond
|
||||
[(zero? span)
|
||||
(set-core-port-line! in line)
|
||||
(set-core-port-column! in column)
|
||||
(set-core-port-position! in position)
|
||||
(set-core-port-state! in state)
|
||||
(set-core-port-cr-state! in cr-state)]
|
||||
(set-location-line! loc line)
|
||||
(set-location-column! loc column)
|
||||
(set-location-position! loc position)
|
||||
(set-location-state! loc state)
|
||||
(set-location-cr-state! loc cr-state)]
|
||||
[else
|
||||
;; span doesn't include CR, LF, or tab
|
||||
(finish-utf-8 end 'state)])]
|
||||
|
|
@ -182,20 +183,21 @@
|
|||
;; a non-whitespace byte.
|
||||
(define (port-count-byte! in b)
|
||||
(increment-offset! in 1)
|
||||
(when (core-port-count? in)
|
||||
(define loc (core-port-count in))
|
||||
(when loc
|
||||
(cond
|
||||
[(or (core-port-state in)
|
||||
(core-port-cr-state in)
|
||||
[(or (location-state loc)
|
||||
(location-cr-state loc)
|
||||
(and (fixnum? b) (b . > . 127))
|
||||
(eq? b (char->integer #\return))
|
||||
(eq? b (char->integer #\newline))
|
||||
(eq? b (char->integer #\tab)))
|
||||
(port-count! in 1 (bytes b) 0)]
|
||||
[else
|
||||
(let ([column (core-port-column in)]
|
||||
[position (core-port-position in)])
|
||||
(when position (set-core-port-position! in (add1 position)))
|
||||
(when column (set-core-port-column! in (add1 column))))])))
|
||||
(let ([column (location-column loc)]
|
||||
[position (location-position loc)])
|
||||
(when position (set-location-position! loc (add1 position)))
|
||||
(when column (set-location-column! loc (add1 column))))])))
|
||||
|
||||
;; in atomic mode
|
||||
(define (port-count-byte-all! in extra-ins b)
|
||||
|
|
@ -205,6 +207,7 @@
|
|||
|
||||
;; in atomic mode
|
||||
(define (increment-offset! in amt)
|
||||
(define old-offset (core-port-offset in))
|
||||
(when old-offset
|
||||
(set-core-port-offset! in (+ amt old-offset))))
|
||||
(unless (core-port-buffer in)
|
||||
(define old-offset (core-port-offset in))
|
||||
(when old-offset
|
||||
(set-core-port-offset! in (+ amt old-offset)))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -162,8 +163,7 @@
|
|||
(set! input-pipe #f)
|
||||
(read-in self dest-bstr dest-start dest-end copy?)]
|
||||
[else
|
||||
(define read-in (core-input-port-read-in input-pipe))
|
||||
(read-in (core-port-self input-pipe) dest-bstr dest-start dest-end copy?)])]
|
||||
(send core-input-port input-pipe read-in dest-bstr dest-start dest-end copy?)])]
|
||||
[else
|
||||
(define r
|
||||
(parameterize-break #f
|
||||
|
|
@ -189,8 +189,7 @@
|
|||
(set! input-pipe #f)
|
||||
(peek-in self dest-bstr dest-start dest-end skip-k progress-evt copy?)]
|
||||
[else
|
||||
(define peek-in (core-input-port-peek-in input-pipe))
|
||||
(peek-in (core-port-self input-pipe) dest-bstr dest-start dest-end skip-k progress-evt copy?)])]
|
||||
(send core-input-port input-pipe peek-in dest-bstr dest-start dest-end skip-k progress-evt copy?)])]
|
||||
[else
|
||||
(define r
|
||||
(parameterize-break #f
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"output-port.rkt"
|
||||
|
|
@ -112,8 +113,7 @@
|
|||
(set! output-pipe #f)
|
||||
(write-out self bstr start end non-block/buffer? enable-break? copy?)]
|
||||
[else
|
||||
(define write-out (core-output-port-write-out output-pipe))
|
||||
(write-out (core-port-self output-pipe) bstr start end non-block/buffer? enable-break? copy?)])]
|
||||
(send core-output-port output-pipe write-out bstr start end non-block/buffer? enable-break? copy?)])]
|
||||
[else
|
||||
(define r
|
||||
;; Always tell user port to re-enable breaks if it blocks, since
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
;; used only when a structure doesn't have `prop:evt`, so `prop:input-port`
|
||||
;; and `prop:output-port` can be mixed with `prop:evt`.
|
||||
|
||||
;; A structue with `prop:secondary-evt` mapped to `port->evt` should
|
||||
;; A structure with `prop:secondary-evt` mapped to `port->evt` should
|
||||
;; also have `prop:input-port-evt` or `prop:input-port-evt`. Those
|
||||
;; properties provide an indirection to avoid a dependency cycle between
|
||||
;; this module and the implement of input and output ports.
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@
|
|||
(raise-network-error #f n "error reading from stream port")
|
||||
(raise-filesystem-error #f n "error reading from stream port"))]
|
||||
[(eqv? n RKTIO_READ_EOF) eof]
|
||||
[(eqv? n 0) (wrap-evt (fd-evt fd RKTIO_POLL_READ (core-port-closed port))
|
||||
[(eqv? n 0) (wrap-evt (fd-evt fd RKTIO_POLL_READ port)
|
||||
(lambda (v) 0))]
|
||||
[else n]))
|
||||
#:read-is-atomic? #t
|
||||
|
|
@ -253,7 +253,7 @@
|
|||
(define custodian-reference
|
||||
(register-fd-close cust fd fd-refcount flush-handle port))
|
||||
|
||||
(set-fd-evt-closed! evt (core-port-closed port))
|
||||
(set-fd-evt-closed! evt port)
|
||||
|
||||
port)
|
||||
|
||||
|
|
@ -319,7 +319,7 @@
|
|||
;; whether the file descriptor has data available:
|
||||
(lambda (fde ctx)
|
||||
(cond
|
||||
[(closed-state-closed? (fd-evt-closed fde))
|
||||
[(core-port-closed? (fd-evt-closed fde))
|
||||
(values (list fde) #f)]
|
||||
[else
|
||||
(define mode (fd-evt-mode fde))
|
||||
|
|
@ -353,7 +353,6 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define (register-fd-close custodian fd fd-refcount flush-handle port)
|
||||
(define closed (core-port-closed port))
|
||||
(unsafe-custodian-register custodian
|
||||
fd
|
||||
;; in atomic mode
|
||||
|
|
@ -361,7 +360,7 @@
|
|||
(when flush-handle
|
||||
(plumber-flush-handle-remove! flush-handle))
|
||||
(fd-close fd fd-refcount)
|
||||
(set-closed-state! closed))
|
||||
(set-closed-state! port))
|
||||
#f
|
||||
#f))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -32,12 +33,12 @@
|
|||
(let ([cp (cond
|
||||
[(input-port? p) (->core-input-port p)]
|
||||
[else (->core-output-port p)])])
|
||||
(define file-position (core-port-file-position cp))
|
||||
(define file-position (method core-port cp file-position))
|
||||
(cond
|
||||
[(and (procedure? file-position) (procedure-arity-includes? file-position 2))
|
||||
(atomically
|
||||
(check-not-closed who cp)
|
||||
(file-position (core-port-self cp) pos))]
|
||||
(file-position cp pos))]
|
||||
[else
|
||||
(raise-arguments-error who
|
||||
"setting position allowed for file-stream and string ports only"
|
||||
|
|
@ -54,7 +55,7 @@
|
|||
[else (raise-argument-error who "port?" orig-p)])])
|
||||
(start-atomic)
|
||||
(check-not-closed who p)
|
||||
(define file-position (core-port-file-position p))
|
||||
(define file-position (method core-port p file-position))
|
||||
(cond
|
||||
[(or (input-port? file-position)
|
||||
(output-port? file-position))
|
||||
|
|
@ -62,7 +63,7 @@
|
|||
(do-simple-file-position who file-position fail-k)]
|
||||
[else
|
||||
(define pos (or (and file-position
|
||||
(file-position (core-port-self p)))
|
||||
(core-port-offset p)))
|
||||
(file-position p))
|
||||
(get-core-port-offset p)))
|
||||
(end-atomic)
|
||||
(or pos (fail-k))])))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"parameter.rkt"
|
||||
"port.rkt"
|
||||
|
|
@ -12,19 +13,20 @@
|
|||
(define/who (flush-output [p (current-output-port)])
|
||||
(check who output-port? p)
|
||||
(let wo-loop ([p p])
|
||||
(let ([write-out (core-output-port-write-out (->core-output-port p))])
|
||||
(cond
|
||||
[(procedure? write-out)
|
||||
(let loop ()
|
||||
(define r (atomically
|
||||
(write-out (core-port-self p) #"" 0 0 #f #f #f)))
|
||||
(let r-loop ([r r])
|
||||
(cond
|
||||
[(eq? r 0) (void)]
|
||||
[(not r) (loop)]
|
||||
[(evt? r) (r-loop (sync r))]
|
||||
[else (error 'flush-output "weird result")])))]
|
||||
[else (wo-loop write-out)]))))
|
||||
(define out (->core-output-port p))
|
||||
(define write-out (method core-output-port out write-out))
|
||||
(cond
|
||||
[(procedure? write-out)
|
||||
(let loop ()
|
||||
(define r (atomically
|
||||
(write-out out #"" 0 0 #f #f #f)))
|
||||
(let r-loop ([r r])
|
||||
(cond
|
||||
[(eq? r 0) (void)]
|
||||
[(not r) (loop)]
|
||||
[(evt? r) (r-loop (sync r))]
|
||||
[else (error 'flush-output "weird result")])))]
|
||||
[else (wo-loop write-out)])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"../host/pthread.rkt"
|
||||
"port.rkt"
|
||||
|
|
@ -9,7 +10,8 @@
|
|||
input-port?
|
||||
->core-input-port
|
||||
(struct-out core-input-port)
|
||||
make-core-input-port)
|
||||
make-core-input-port
|
||||
compat-input-port-self)
|
||||
|
||||
(define-values (prop:input-port input-port-via-property? input-port-ref)
|
||||
(make-struct-type-property 'input-port
|
||||
|
|
@ -47,113 +49,110 @@
|
|||
[who (raise-argument-error who "input-port?" v)]
|
||||
[else empty-input-port]))
|
||||
|
||||
(struct core-input-port core-port
|
||||
(
|
||||
;; Various functions below are called in atomic mode. The intent of
|
||||
;; atomic mode is to ensure that the completion and return of the
|
||||
;; function is atomic with respect to some further activity, such
|
||||
;; as position and line counting. Also, a guard against operations
|
||||
;; on a closed port precedes most operations. Any of the functions
|
||||
;; is free to exit and re-enter atomic mode, but they may take on
|
||||
;; the burden of re-checking for a closed port. Leave atomic mode
|
||||
;; explicitly before raising an exception.
|
||||
(class core-input-port #:extends core-port
|
||||
(field
|
||||
[pending-eof? #f]
|
||||
[read-handler #f])
|
||||
|
||||
prepare-change ; #f or (-*> void)
|
||||
;; Called in atomic mode
|
||||
;; May leave atomic mode temporarily, but on return,
|
||||
;; ensures that other atomic operations are ok to
|
||||
;; change the port. The main use of `prepare-change`
|
||||
;; is to pause and `port-commit-peeked` attempts to
|
||||
;; not succeed while a potential change is in
|
||||
;; progress, where the commit attempts can resume after
|
||||
;; atomic mode is left. The `close` operation
|
||||
;; is *not* guarded by a call to `prepare-change`.
|
||||
(public
|
||||
|
||||
read-byte ; #f or (-*> (or/c byte? eof-object? evt?))
|
||||
;; Called in atomic mode.
|
||||
;; This shortcut is optional.
|
||||
;; Non-blocking byte read, where an event must be
|
||||
;; returned if no byte is available. The event's result
|
||||
;; is ignored, so it should not consume a byte.
|
||||
;; #f or (-*> void)
|
||||
;; Called in atomic mode
|
||||
;; May leave atomic mode temporarily, but on return, ensures that
|
||||
;; other atomic operations are ok to change the port. The main use
|
||||
;; of `prepare-change` is to pause and `port-commit-peeked`
|
||||
;; attempts to not succeed while a potential change is in progress,
|
||||
;; where the commit attempts can resume after atomic mode is left.
|
||||
;; The `close` operation is *not* guarded by a call to
|
||||
;; `prepare-change`.
|
||||
[prepare-change #f]
|
||||
|
||||
read-in ; port or (bytes start-k end-k copy? -*> (or/c integer? ...))
|
||||
;; Called in atomic mode.
|
||||
;; A port value redirects to the port. Otherwise, the function
|
||||
;; never blocks, and can assume `(- end-k start-k)` is non-zero.
|
||||
;; The `copy?` flag indicates that the given byte string should
|
||||
;; not be exposed to untrusted code, and instead of should be
|
||||
;; copied if necessary. The return values are the same as
|
||||
;; documented for `make-input-port`, except that a pipe result
|
||||
;; is not allowed (or, more precisely, it's treated as an event).
|
||||
;; port or (bytes start-k end-k copy? -*> (or/c integer? ...))
|
||||
;; Called in atomic mode.
|
||||
;; A port value redirects to the port. Otherwise, the function
|
||||
;; never blocks, and can assume `(- end-k start-k)` is non-zero.
|
||||
;; The `copy?` flag indicates that the given byte string should not
|
||||
;; be exposed to untrusted code, and instead of should be copied if
|
||||
;; necessary. The return values are the same as documented for
|
||||
;; `make-input-port`, except that a pipe result is not allowed (or,
|
||||
;; more precisely, it's treated as an event).
|
||||
[read-in (lambda (bstr start end copy?) eof)]
|
||||
|
||||
peek-byte ; #f or (-*> (or/c byte? eof-object? evt?))
|
||||
;; Called in atomic mode.
|
||||
;; This shortcut is optional.
|
||||
;; Non-blocking byte read, where an event must be
|
||||
;; returned if no byte is available. The event's result
|
||||
;; is ignored.
|
||||
;; port or (bytes start-k end-k skip-k progress-evt copy? -*> (or/c integer? ...))
|
||||
;; Called in atomic mode.
|
||||
;; A port value redirects to the port. Otherwise, the function
|
||||
;; never blocks, and it can assume that `(- end-k start-k)` is
|
||||
;; non-zero. The `copy?` flag is the same as for `read-in`. The
|
||||
;; return values are the same as documented for `make-input-port`.
|
||||
[peek-in (lambda (bstr start end progress-evt copy?) eof)]
|
||||
|
||||
peek-in ; port or (bytes start-k end-k skip-k progress-evt copy? -*> (or/c integer? ...))
|
||||
;; Called in atomic mode.
|
||||
;; A port value redirects to the port. Otherwise, the function
|
||||
;; never blocks, and it can assume that `(- end-k start-k)` is non-zero.
|
||||
;; The `copy?` flag is the same as for `read-in`. The return values
|
||||
;; are the same as documented for `make-input-port`.
|
||||
;; port or ((->) -*> (or/c boolean? evt))
|
||||
;; Called in atomic mode.
|
||||
;; A port value makes sense when `peek-in` has a port value.
|
||||
;; Otherwise, check whether a peek on one byte would succeed
|
||||
;; without blocking and return a boolean, or return an event that
|
||||
;; effectively does the same. The event's value doesn't matter,
|
||||
;; because it will be wrapped to return some original port. When
|
||||
;; `byte-ready` is a function, it should call the given function
|
||||
;; (for its side effect) when work has been done that might unblock
|
||||
;; this port or some other port.
|
||||
[byte-ready (lambda (work-done!) #t)]
|
||||
|
||||
byte-ready ; port or ((->) -*> (or/c boolean? evt))
|
||||
;; Called in atomic mode.
|
||||
;; A port value makes sense when `peek-in` has a port value.
|
||||
;; Otherwise, check whether a peek on one byte would succeed
|
||||
;; without blocking and return a boolean, or return an event
|
||||
;; that effectively does the same. The event's value doesn't
|
||||
;; matter, because it will be wrapped to return some original
|
||||
;; port. When `byte-ready` is a function, it should call the
|
||||
;; given function (for its side effect) when work has been
|
||||
;; done that might unblock this port or some other port.
|
||||
;; #f or (-*> evt?)
|
||||
;; *Not* called in atomic mode.
|
||||
;; Optional support for progress events, and may be called on a
|
||||
;; closed port.
|
||||
[get-progress-evt #f]
|
||||
|
||||
get-progress-evt ; #f or (-*> evt?)
|
||||
;; *Not* called in atomic mode.
|
||||
;; Optional support for progress events, and may be
|
||||
;; called on a closed port.
|
||||
;; (amt-k progress-evt? evt? (bytes? -> any) -*> boolean)
|
||||
;; Called in atomic mode.
|
||||
;; Goes with `get-progress-evt`. The final `evt?` argument is
|
||||
;; constrained to a few kinds of events; see docs for
|
||||
;; `port-commit-peeked` for more information. On success, a
|
||||
;; completion function is called in atomic mode, but possibly in a
|
||||
;; different thread, with the committed bytes. The result is a
|
||||
;; boolean indicating success or failure.
|
||||
[commit (lambda (amt progress-evt ext-evt finish) #f)])
|
||||
|
||||
commit ; (amt-k progress-evt? evt? (bytes? -> any) -*> boolean)
|
||||
;; Called in atomic mode.
|
||||
;; Goes with `get-progress-evt`. The final `evt?`
|
||||
;; argument is constrained to a few kinds of events;
|
||||
;; see docs for `port-commit-peeked` for more information.
|
||||
;; On success, a completion function is called in atomic mode,
|
||||
;; but possibly in a different thread, with the committed bytes.
|
||||
;; The result is a boolean indicating success or failure.
|
||||
(property
|
||||
[prop:input-port-evt (lambda (i)
|
||||
;; not atomic mode
|
||||
(let ([i (->core-input-port i)])
|
||||
(cond
|
||||
[(core-port-closed? i)
|
||||
always-evt]
|
||||
[else
|
||||
(define byte-ready (method core-input-port i byte-ready))
|
||||
(cond
|
||||
[(input-port? byte-ready)
|
||||
byte-ready]
|
||||
[else
|
||||
(poller-evt
|
||||
(poller
|
||||
(lambda (self poll-ctx)
|
||||
;; atomic mode
|
||||
(define v (byte-ready i
|
||||
(lambda ()
|
||||
(schedule-info-did-work! (poll-ctx-sched-info poll-ctx)))))
|
||||
(cond
|
||||
[(evt? v)
|
||||
(values #f v)]
|
||||
[(eq? v #t)
|
||||
(values (list #t) #f)]
|
||||
[else
|
||||
(values #f self)]))))])])))]))
|
||||
|
||||
[pending-eof? #:mutable]
|
||||
[read-handler #:mutable])
|
||||
#:authentic
|
||||
#:property prop:input-port-evt (lambda (i)
|
||||
;; not atomic mode
|
||||
(let ([i (->core-input-port i)])
|
||||
(cond
|
||||
[(closed-state-closed? (core-port-closed i))
|
||||
always-evt]
|
||||
[else
|
||||
(define byte-ready (core-input-port-byte-ready i))
|
||||
(cond
|
||||
[(input-port? byte-ready)
|
||||
byte-ready]
|
||||
[else
|
||||
(poller-evt
|
||||
(poller
|
||||
(lambda (self poll-ctx)
|
||||
;; atomic mode
|
||||
(define v (byte-ready (core-port-self i)
|
||||
(lambda ()
|
||||
(schedule-info-did-work! (poll-ctx-sched-info poll-ctx)))))
|
||||
(cond
|
||||
[(evt? v)
|
||||
(values #f v)]
|
||||
[(eq? v #t)
|
||||
(values (list #t) #f)]
|
||||
[else
|
||||
(values #f self)]))))])]))))
|
||||
;; ----------------------------------------
|
||||
|
||||
(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]
|
||||
|
|
@ -172,40 +171,43 @@
|
|||
#:init-offset [init-offset 0]
|
||||
#:file-position [file-position #f]
|
||||
#:buffer-mode [buffer-mode #f])
|
||||
(core-input-port name
|
||||
data
|
||||
self
|
||||
|
||||
close
|
||||
count-lines!
|
||||
get-location
|
||||
file-position
|
||||
buffer-mode
|
||||
|
||||
(closed-state #f #f)
|
||||
init-offset ; offset
|
||||
#f ; count?
|
||||
#f ; state
|
||||
#f ; cr-state
|
||||
#f ; line
|
||||
#f ; column
|
||||
#f ; position
|
||||
|
||||
prepare-change
|
||||
read-byte
|
||||
read-in
|
||||
peek-byte
|
||||
peek-in
|
||||
byte-ready
|
||||
get-progress-evt
|
||||
commit
|
||||
#f ; pending-eof?
|
||||
#f)) ; read-handler
|
||||
|
||||
(define empty-input-port
|
||||
(make-core-input-port #:name 'empty
|
||||
#:self #f
|
||||
#:read-in (lambda (self bstr start-k end-k copy?) eof)
|
||||
#:peek-in (lambda (self bstr start-k end-k skip-k copy?) eof)
|
||||
#:byte-ready (lambda (self did-work!) #f)
|
||||
#:close void))
|
||||
(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]))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require racket/fixnum
|
||||
"../common/check.rkt"
|
||||
"input-port.rkt"
|
||||
"read-and-peek.rkt"
|
||||
"bytes-input.rkt"
|
||||
"string-input.rkt"
|
||||
"parameter.rkt"
|
||||
|
|
@ -17,7 +18,7 @@
|
|||
(define-syntax-rule (define-read-line read-line
|
||||
make-string string-set!
|
||||
string-copy! substring
|
||||
do-read-char peek-char
|
||||
read-a-char peek-a-char
|
||||
as-char)
|
||||
(define/who (read-line [orig-in (current-input-port)] [mode 'linefeed])
|
||||
(define in (->core-input-port orig-in who))
|
||||
|
|
@ -28,7 +29,7 @@
|
|||
(define crlf? (case mode [(return-linefeed any) #t] [else #f]))
|
||||
(define init-len 32)
|
||||
(let loop ([str (make-string init-len)] [len init-len] [pos 0])
|
||||
(define ch (do-read-char 'read-line in))
|
||||
(define ch (read-a-char 'read-line in))
|
||||
(define (keep-char)
|
||||
(if (pos . fx< . len)
|
||||
(begin
|
||||
|
|
@ -48,8 +49,8 @@
|
|||
(eqv? ch (as-char #\return)))
|
||||
(cond
|
||||
[(and crlf?
|
||||
(eqv? (peek-char in) (as-char #\linefeed)))
|
||||
(do-read-char 'read-line in)
|
||||
(eqv? (peek-a-char 'read-line in 0) (as-char #\linefeed)))
|
||||
(read-a-char 'read-line in)
|
||||
(substring str 0 pos)]
|
||||
[cr?
|
||||
(substring str 0 pos)]
|
||||
|
|
@ -62,11 +63,11 @@
|
|||
(define-read-line read-line
|
||||
make-string string-set!
|
||||
string-copy! substring
|
||||
do-read-char/core-port peek-char
|
||||
read-a-char peek-a-char
|
||||
values)
|
||||
|
||||
(define-read-line read-bytes-line
|
||||
make-bytes bytes-set!
|
||||
bytes-copy! subbytes
|
||||
do-read-byte/core-port peek-byte
|
||||
read-a-byte peek-a-byte
|
||||
char->integer)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"../host/pthread.rkt"
|
||||
"port.rkt"
|
||||
|
|
@ -9,7 +10,8 @@
|
|||
output-port?
|
||||
->core-output-port
|
||||
(struct-out core-output-port)
|
||||
make-core-output-port)
|
||||
make-core-output-port
|
||||
compat-output-port-self)
|
||||
|
||||
(define-values (prop:output-port output-port-via-property? output-port-ref)
|
||||
(make-struct-type-property 'output-port
|
||||
|
|
@ -47,58 +49,83 @@
|
|||
[who (raise-argument-error who "output-port?" v)]
|
||||
[else empty-output-port]))
|
||||
|
||||
(struct core-output-port core-port
|
||||
(
|
||||
;; Various functions below are called in atomic mode; see
|
||||
;; `core-input-port` for more information on atomicity.
|
||||
(class core-output-port #:extends core-port
|
||||
(field
|
||||
[evt always-evt] ; An evt that is ready when writing a byte won't block
|
||||
[write-handler #f]
|
||||
[print-handler #f]
|
||||
[display-handler #f])
|
||||
|
||||
evt ; An evt that is ready when writing a byte won't block
|
||||
(public
|
||||
;; port or (bstr start-k end-k no-block/buffer? enable-break? copy? -*> ...)
|
||||
;; Called in atomic mode.
|
||||
;; Doesn't block if `no-block/buffer?` is true. Does enable breaks
|
||||
;; while blocking if `enable-break?` is true. The `copy?` flag
|
||||
;; indicates that the given byte string should not be exposed to
|
||||
;; untrusted code, and instead of should be copied if necessary.
|
||||
;; The return values are the same as documented for
|
||||
;; `make-output-port`.
|
||||
[write-out (lambda (bstr start-k end-k no-block/buffer? enable-break? copy?)
|
||||
(- start-k end-k))]
|
||||
|
||||
;; #f or (any no-block/buffer? enable-break? -*> boolean?)
|
||||
;; Called in atomic mode.
|
||||
[write-out-special #f]
|
||||
|
||||
write-out ; port or (bstr start-k end-k no-block/buffer? enable-break? copy? -*> ...)
|
||||
;; Called in atomic mode.
|
||||
;; Doesn't block if `no-block/buffer?` is true.
|
||||
;; Does enable breaks while blocking if `enable-break?` is true.
|
||||
;; The `copy?` flag indicates that the given byte string should
|
||||
;; not be exposed to untrusted code, and instead of should be
|
||||
;; copied if necessary. The return values are the same as
|
||||
;; documented for `make-output-port`.
|
||||
;; #f or (bstr start-k end-k -*> evt?)
|
||||
;; Called in atomic mode.
|
||||
;; The given bstr should not be exposed to untrusted code.
|
||||
[get-write-evt (lambda (bstr start-k end-k) always-evt)]
|
||||
|
||||
write-out-special ; (any no-block/buffer? enable-break? -*> boolean?)
|
||||
;; Called in atomic mode.
|
||||
;; #f or (any -*> evt?)
|
||||
;; *Not* called in atomic mode.
|
||||
[get-write-special-evt #f])
|
||||
|
||||
get-write-evt ; (port bstr start-k end-k -*> evt?)
|
||||
;; Called in atomic mode.
|
||||
;; Note the extra "self" argument as a port, which is useful
|
||||
;; for implementing `count-write-evt-via-write-out`.
|
||||
;; The given bstr should not be exposed to untrusted code.
|
||||
(property
|
||||
[prop:output-port-evt (lambda (o)
|
||||
;; not atomic mode
|
||||
(let ([o (->core-output-port o)])
|
||||
(choice-evt
|
||||
(list
|
||||
(poller-evt
|
||||
(poller
|
||||
(lambda (self sched-info)
|
||||
;; atomic mode
|
||||
(cond
|
||||
[(core-port-closed? o)
|
||||
(values '(#t) #f)]
|
||||
[else (values #f self)]))))
|
||||
(core-output-port-evt o)))))]))
|
||||
|
||||
get-write-special-evt ; (-*> evt?)
|
||||
;; *Not* called in atomic mode.
|
||||
|
||||
[write-handler #:mutable]
|
||||
[print-handler #:mutable]
|
||||
[display-handler #:mutable])
|
||||
#:authentic
|
||||
#:property prop:output-port-evt (lambda (o)
|
||||
;; not atomic mode
|
||||
(let ([o (->core-output-port o)])
|
||||
(choice-evt
|
||||
(list
|
||||
(poller-evt
|
||||
(poller
|
||||
(lambda (self sched-info)
|
||||
;; atomic mode
|
||||
(cond
|
||||
[(closed-state-closed? (core-port-closed o))
|
||||
(values '(#t) #f)]
|
||||
[else (values #f self)]))))
|
||||
(core-output-port-evt o))))))
|
||||
;; If `write-out` is always atomic (in no-block, no-buffer mode),
|
||||
;; then an event can poll `write-out`
|
||||
(define (get-write-evt-via-write-out count-write-evt-via-write-out)
|
||||
(lambda (out src-bstr src-start src-end)
|
||||
(write-evt
|
||||
;; in atomic mode:
|
||||
(lambda (self-evt)
|
||||
(define v (send core-output-port out write-out src-bstr src-start src-end #f #f #t))
|
||||
(when (exact-integer? v)
|
||||
(count-write-evt-via-write-out out v src-bstr src-start))
|
||||
(if (evt? v)
|
||||
(values #f (replace-evt v self-evt))
|
||||
(values (list v) #f))))))
|
||||
|
||||
(struct write-evt (proc)
|
||||
#:property prop:evt (poller
|
||||
(lambda (self sched-info)
|
||||
((write-evt-proc self) self))))
|
||||
|
||||
(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
|
||||
|
|
@ -114,54 +141,49 @@
|
|||
#:file-position [file-position #f]
|
||||
#:init-offset [init-offset 0]
|
||||
#:buffer-mode [buffer-mode #f])
|
||||
(core-output-port name
|
||||
data
|
||||
self
|
||||
|
||||
close
|
||||
count-lines!
|
||||
get-location
|
||||
file-position
|
||||
buffer-mode
|
||||
|
||||
(closed-state #f #f)
|
||||
init-offset ; offset
|
||||
#f ; count?
|
||||
#f ; state
|
||||
#f ; cr-state
|
||||
#f ; line
|
||||
#f ; column
|
||||
#f ; position
|
||||
|
||||
evt
|
||||
write-out
|
||||
write-out-special
|
||||
(or get-write-evt
|
||||
(and count-write-evt-via-write-out
|
||||
;; If `write-out` is always atomic (in no-block, no-buffer mode),
|
||||
;; then an event can poll `write-out`:
|
||||
(lambda (self o src-bstr src-start src-end)
|
||||
(write-evt
|
||||
;; in atomic mode:
|
||||
(lambda (self-evt)
|
||||
(define v (write-out self src-bstr src-start src-end #f #f #t))
|
||||
(when (exact-integer? v)
|
||||
(count-write-evt-via-write-out self o v src-bstr src-start))
|
||||
(if (evt? v)
|
||||
(values #f (replace-evt v self-evt))
|
||||
(values (list v) #f)))))))
|
||||
get-write-special-evt
|
||||
|
||||
#f ; write-handler
|
||||
#f ; display-handler
|
||||
#f)) ; print-handler
|
||||
|
||||
(define empty-output-port
|
||||
(make-core-output-port #:name 'empty
|
||||
#:self #f
|
||||
#:evt always-evt
|
||||
#:write-out (lambda (self bstr start end no-buffer? enable-break?)
|
||||
(- end start))
|
||||
#:write-out-special (lambda (self v no-buffer? enable-break?)
|
||||
#t)
|
||||
#:close void))
|
||||
(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]))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../host/thread.rkt"
|
||||
(require "../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
"output-port.rkt"
|
||||
|
|
@ -25,7 +26,7 @@
|
|||
|
||||
;; in atomic mode
|
||||
(define (prepare-change self)
|
||||
((core-input-port-prepare-change peek-pipe-i) (core-port-self peek-pipe-i)))
|
||||
(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])
|
||||
|
|
@ -39,8 +40,7 @@
|
|||
[(eqv? v 0) 0]
|
||||
[else
|
||||
(let loop ([wrote 0])
|
||||
(define write-out (core-output-port-write-out peek-pipe-o))
|
||||
(define just-wrote (write-out (core-port-self peek-pipe-o) buf wrote v #t #f #f))
|
||||
(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)))
|
||||
|
|
@ -54,8 +54,7 @@
|
|||
(let try-again ()
|
||||
(cond
|
||||
[(positive? (pipe-content-length peek-pipe-i))
|
||||
(define read-in (core-input-port-read-in peek-pipe-i))
|
||||
(read-in (core-port-self peek-pipe-i) dest-bstr start end copy?)]
|
||||
(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
|
||||
|
|
@ -74,24 +73,6 @@
|
|||
(progress!))
|
||||
v])])))
|
||||
|
||||
;; in atomic mode
|
||||
(define (read-byte self)
|
||||
(define b ((core-input-port-read-byte peek-pipe-i) (core-port-self peek-pipe-i)))
|
||||
(cond
|
||||
[(or (fixnum? b) (eof-object? b))
|
||||
b]
|
||||
[peeked-eof?
|
||||
(set! peeked-eof? #f)
|
||||
;; an EOF doesn't count as progress
|
||||
eof]
|
||||
[else
|
||||
(define v (pull-some-bytes #:keep-eof? #f))
|
||||
(cond
|
||||
[(retry-pull? v) (read-byte self)]
|
||||
[else
|
||||
(progress!)
|
||||
v])]))
|
||||
|
||||
;; in atomic mode
|
||||
(define (do-peek-in self dest-bstr start end skip progress-evt copy?)
|
||||
(let try-again ()
|
||||
|
|
@ -104,8 +85,7 @@
|
|||
#f]
|
||||
[(and peek-pipe-i
|
||||
(peeked-amt . > . skip))
|
||||
(define peek-in (core-input-port-peek-in peek-pipe-i))
|
||||
(peek-in (core-port-self peek-pipe-i) dest-bstr start end skip progress-evt copy?)]
|
||||
(send core-input-port peek-pipe-i peek-in dest-bstr start end skip progress-evt copy?)]
|
||||
[peeked-eof?
|
||||
eof]
|
||||
[else
|
||||
|
|
@ -114,19 +94,6 @@
|
|||
(try-again)
|
||||
v)])))
|
||||
|
||||
;; in atomic mode
|
||||
(define (peek-byte self)
|
||||
(cond
|
||||
[(positive? (pipe-content-length peek-pipe-i))
|
||||
((core-input-port-peek-byte peek-pipe-i) (core-port-self peek-pipe-i))]
|
||||
[peeked-eof?
|
||||
eof]
|
||||
[else
|
||||
(define v (pull-some-bytes))
|
||||
(if (retry-pull? v)
|
||||
(peek-byte self)
|
||||
v)]))
|
||||
|
||||
;; in atomic mode
|
||||
(define (do-byte-ready self work-done!)
|
||||
(cond
|
||||
|
|
@ -151,15 +118,15 @@
|
|||
|
||||
;; in atomic mode
|
||||
(define (get-progress-evt self)
|
||||
((core-input-port-get-progress-evt peek-pipe-i) (core-port-self peek-pipe-i)))
|
||||
(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:
|
||||
((core-input-port-commit peek-pipe-i) (core-port-self peek-pipe-i) 0 #f #f void))
|
||||
(send core-input-port peek-pipe-i commit 0 #f #f void))
|
||||
|
||||
(define (commit self amt evt ext-evt finish)
|
||||
((core-input-port-commit peek-pipe-i) (core-port-self peek-pipe-i) amt evt ext-evt finish))
|
||||
(send core-input-port peek-pipe-i commit amt evt ext-evt finish))
|
||||
|
||||
(define do-buffer-mode
|
||||
(case-lambda
|
||||
|
|
@ -173,9 +140,7 @@
|
|||
|
||||
#:prepare-change prepare-change
|
||||
|
||||
#:read-byte read-byte
|
||||
#:read-in do-read-in
|
||||
#:peek-byte peek-byte
|
||||
#:peek-in do-peek-in
|
||||
#:byte-ready do-byte-ready
|
||||
|
||||
|
|
|
|||
|
|
@ -35,28 +35,30 @@
|
|||
(pipe-data? (core-port-data (->core-output-port p)))))
|
||||
|
||||
(define (pipe-content-length p)
|
||||
((pipe-data-get-content-length
|
||||
(core-port-data
|
||||
(cond
|
||||
[(pipe-input-port? p) (->core-input-port p)]
|
||||
[(pipe-output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(raise-argument-error 'pipe-contact-length "(or/c pipe-input-port? pipe-output-port?)" p)])))
|
||||
(core-port-self p)))
|
||||
(define cp
|
||||
(cond
|
||||
[(pipe-input-port? p) (->core-input-port p)]
|
||||
[(pipe-output-port? p) (->core-output-port p)]
|
||||
[else
|
||||
(raise-argument-error 'pipe-contact-length "(or/c pipe-input-port? pipe-output-port?)" p)]))
|
||||
((pipe-data-get-content-length (core-port-data cp))
|
||||
(if (core-input-port? cp)
|
||||
(compat-input-port-self cp)
|
||||
(compat-output-port-self cp))))
|
||||
|
||||
;; in atomic mode:
|
||||
(define pipe-write-position
|
||||
(case-lambda
|
||||
[(p) ((pipe-data-write-position (core-port-data p)) (core-port-self p))]
|
||||
[(p pos) ((pipe-data-write-position (core-port-data p)) (core-port-self p) pos)]))
|
||||
[(p) ((pipe-data-write-position (core-port-data p)) (compat-output-port-self p))]
|
||||
[(p pos) ((pipe-data-write-position (core-port-data p)) (compat-output-port-self p) pos)]))
|
||||
|
||||
;; in atomic mode:
|
||||
(define (pipe-discard-all p)
|
||||
((pipe-data-discard-all (core-port-data p)) (core-port-self p)))
|
||||
((pipe-data-discard-all (core-port-data p)) (compat-output-port-self p)))
|
||||
|
||||
;; in atomic mode:
|
||||
;; in atomic mode:x
|
||||
(define (pipe-get-content p bstr start-pos)
|
||||
((pipe-data-get-content (core-port-data p)) (core-port-self p) bstr start-pos))
|
||||
((pipe-data-get-content (core-port-data p)) (compat-output-port-self p) bstr start-pos))
|
||||
|
||||
(define-constructor (make-pipe-ends [limit #f] [input-name 'pipe] [output-name 'pipe]
|
||||
#:need-input? [need-input? #t])
|
||||
|
|
|
|||
|
|
@ -1,44 +1,99 @@
|
|||
#lang racket/base
|
||||
(require "../host/thread.rkt"
|
||||
(require "../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"../host/pthread.rkt"
|
||||
"evt.rkt"
|
||||
"place-message.rkt")
|
||||
|
||||
(provide (struct-out core-port)
|
||||
(struct-out closed-state))
|
||||
(struct-out location)
|
||||
get-core-port-offset)
|
||||
|
||||
(struct core-port (name ; anything, reported as `object-name` for the port
|
||||
data ; anything, effectively a subtype indicator
|
||||
(class core-port
|
||||
(field
|
||||
[name 'port #:immutable] ; anything, reported as `object-name` for the port
|
||||
|
||||
;; A "method" or "-*>" gets this value back as its
|
||||
;; first argument:
|
||||
self ; anything, passed to every method
|
||||
[data #f] ; FIXME: remove after all uses are converted
|
||||
|
||||
close ; -*> (void)
|
||||
;; Called in atomic mode.
|
||||
;; When `buffer` is #f, it enables a shortcut for reading and
|
||||
;; writing, where `buffer-pos` must also be less than `buffer-end`
|
||||
;; for the shortcut to apply. The shortcut is not necessarily
|
||||
;; always taken, just if it is used, the `buffer-pos` position can
|
||||
;; be adjusted and the port's methods must adapt accordingly. The
|
||||
;; `buffer` and `buffer-end` fields are modified only by the port's
|
||||
;; methods, however.
|
||||
;;
|
||||
;; For an input port, shortcut mode implies that `prepare-change`
|
||||
;; does not need to be called, and no checking is needed for whether
|
||||
;; the port is closed.
|
||||
;;
|
||||
;; A non-#f `buffer` further implies that `buffer-pos` should be
|
||||
;; added to `offset` to get the true offset.
|
||||
;;
|
||||
;; Shortcut mode must be disabled when line counting is enabled,
|
||||
;; since shortcut mode skips explicit count.
|
||||
[buffer #f]
|
||||
[buffer-pos 0] ; if < `buffer-end`, allows direct read/write on `buffer`
|
||||
[buffer-end 0]
|
||||
|
||||
[closed? #f]
|
||||
[closed-sema #f]
|
||||
|
||||
[offset 0] ; count plain bytes; add `(- buffer-pos buffer-start)`
|
||||
[count #f]) ; #f or a `location`
|
||||
|
||||
;; Various methods below are called in atomic mode. The intent of
|
||||
;; atomic mode is to ensure that the completion and return of the
|
||||
;; function is atomic with respect to some further activity, such
|
||||
;; as position and line counting. Also, a guard against operations
|
||||
;; on a closed port precedes most operations. Any of the functions
|
||||
;; is free to exit and re-enter atomic mode, but they may take on
|
||||
;; the burden of re-checking for a closed port. Leave atomic mode
|
||||
;; explicitly before raising an exception.
|
||||
|
||||
count-lines! ; #f or method called in atomic mode
|
||||
get-location ; #f or method called in atomic mode
|
||||
file-position ; #f, port, or method called in atomic mode
|
||||
buffer-mode ; #f or method in atomic mode
|
||||
(public
|
||||
;; -*> (void)
|
||||
;; Called in atomic mode.
|
||||
;; Reqeusts a close, and the port is closed if/when
|
||||
;; the method returns.
|
||||
[close (lambda () (void))]
|
||||
|
||||
closed ; `closed-state`
|
||||
;; #f or (-*> (void))
|
||||
;; Called in atomic mode.
|
||||
;; Notifies the port that line counting is enabled, and
|
||||
;; `get-location` can be called afterward (if it is defined)
|
||||
[count-lines! #f]
|
||||
|
||||
[offset #:mutable] ; count plain bytes
|
||||
[count? #:mutable] ; whether line counting is enabled
|
||||
[state #:mutable] ; state of UTF-8 decoding
|
||||
[cr-state #:mutable] ; state of CRLF counting as a single LF
|
||||
[line #:mutable] ; count newlines
|
||||
[column #:mutable] ; count UTF-8 characters in line
|
||||
[position #:mutable]) ; count UTF-8 characters
|
||||
#:authentic
|
||||
#:property prop:unsafe-authentic-override #t ; allow evt chaperone
|
||||
#:property prop:object-name (struct-field-index name)
|
||||
#:property prop:secondary-evt port->evt
|
||||
#:property prop:place-message (lambda (p)
|
||||
(define data (core-port-data p))
|
||||
(data->place-message data p)))
|
||||
;; #f or (-*> (values line-or-#f column-or-#f position-or-#f))
|
||||
;; Called in atomic mode.
|
||||
;; Returns the location of the next character. If #f, this method
|
||||
;; is implemented externally.
|
||||
[get-location #f] ; #f or method called in atomic mode
|
||||
|
||||
(struct closed-state ([closed? #:mutable]
|
||||
[closed-sema #:mutable]) ; #f or a semaphore posed on close
|
||||
#:authentic)
|
||||
;; #f or (U (-*> position-k) (position-k -*> (void))
|
||||
;; Called in atomic mode.
|
||||
;; If not #f, the port implements `file-position`.
|
||||
[file-position #f]
|
||||
|
||||
;; #f or (U (-*> mode-sym) (mode-sym -*> (void))
|
||||
;; Called in atomic mode.
|
||||
;; If not #f, the port implements buffer-mode selection.
|
||||
[buffer-mode #f])
|
||||
|
||||
(property
|
||||
[prop:unsafe-authentic-override #t] ; allow evt chaperone
|
||||
[prop:object-name (struct-field-index name)]
|
||||
[prop:secondary-evt port->evt]))
|
||||
|
||||
(struct location ([state #:mutable] ; state of UTF-8 decoding
|
||||
[cr-state #:mutable] ; state of CRLF counting as a single LF
|
||||
[line #:mutable] ; count newlines
|
||||
[column #:mutable] ; count UTF-8 characters in line
|
||||
[position #:mutable])) ; count UTF-8 characters
|
||||
|
||||
(define (get-core-port-offset p)
|
||||
(define offset (core-port-offset p))
|
||||
(and offset
|
||||
(if (core-port-buffer p)
|
||||
(+ offset (core-port-buffer-pos p))
|
||||
offset)))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "port.rkt"
|
||||
(require "../common/class.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt")
|
||||
|
||||
(provide prepare-change)
|
||||
|
|
@ -7,6 +8,6 @@
|
|||
;; in atomic mode
|
||||
;; ... but may leave and return to atomic mode
|
||||
(define (prepare-change in)
|
||||
(define prepare-change (core-input-port-prepare-change in))
|
||||
(define prepare-change (method core-input-port in prepare-change))
|
||||
(when prepare-change
|
||||
(prepare-change (core-port-self in))))
|
||||
(prepare-change in)))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"parameter.rkt"
|
||||
"port.rkt"
|
||||
|
|
@ -34,14 +35,14 @@
|
|||
(define/who (port-provides-progress-evts? in)
|
||||
(check who input-port? in)
|
||||
(let ([in (->core-input-port in)])
|
||||
(and (core-input-port-get-progress-evt in) #t)))
|
||||
(and (method core-input-port in get-progress-evt) #t)))
|
||||
|
||||
(define/who (port-progress-evt orig-in)
|
||||
(check who input-port? orig-in)
|
||||
(let ([in (->core-input-port orig-in)])
|
||||
(define get-progress-evt (core-input-port-get-progress-evt in))
|
||||
(define get-progress-evt (method core-input-port in get-progress-evt))
|
||||
(if get-progress-evt
|
||||
(progress-evt orig-in (get-progress-evt (core-port-self in)))
|
||||
(progress-evt orig-in (get-progress-evt in))
|
||||
(raise-arguments-error 'port-progress-evt
|
||||
"port does not provide progress evts"
|
||||
"port" orig-in))))
|
||||
|
|
@ -55,14 +56,14 @@
|
|||
(check who input-port? in)
|
||||
(check-progress-evt who progress-evt in)
|
||||
(let ([in (->core-input-port in)])
|
||||
(define commit (core-input-port-commit in))
|
||||
(atomically
|
||||
;; We specially skip a check on whether the port is closed,
|
||||
;; since that's handled as the progress evt becoming ready
|
||||
(commit (core-port-self in) amt (progress-evt-evt progress-evt) evt
|
||||
;; in atomic mode (but maybe leaves atomic mode in between)
|
||||
(lambda (bstr)
|
||||
(port-count! in (bytes-length bstr) bstr 0))))))
|
||||
(send core-input-port in commit
|
||||
amt (progress-evt-evt progress-evt) evt
|
||||
;; in atomic mode (but maybe leaves atomic mode in between)
|
||||
(lambda (bstr)
|
||||
(port-count! in (bytes-length bstr) bstr 0))))))
|
||||
|
||||
(define (check-progress-evt who progress-evt in)
|
||||
(unless (progress-evt?* progress-evt in)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "../common/internal-error.rkt"
|
||||
(require racket/fixnum
|
||||
"../common/internal-error.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
|
|
@ -10,9 +12,9 @@
|
|||
(provide read-some-bytes!
|
||||
peek-some-bytes!
|
||||
|
||||
do-read-byte
|
||||
read-a-byte
|
||||
read-byte-via-bytes
|
||||
do-peek-byte
|
||||
peek-a-byte
|
||||
peek-byte-via-bytes)
|
||||
|
||||
;; Read up to `(- end start)` bytes, producing at least a
|
||||
|
|
@ -47,7 +49,7 @@
|
|||
[(= start end) ; intentionally before the port-closed check
|
||||
(end-atomic)
|
||||
0]
|
||||
[(closed-state-closed? (core-port-closed in))
|
||||
[(core-port-closed? in)
|
||||
(check-not-closed who in)]
|
||||
;; previously detected EOF?
|
||||
[(core-input-port-pending-eof? in)
|
||||
|
|
@ -56,58 +58,70 @@
|
|||
(end-atomic)
|
||||
eof]
|
||||
[else
|
||||
;; normal mode...
|
||||
(define read-in (core-input-port-read-in in))
|
||||
(define buf-pos (core-port-buffer-pos in))
|
||||
(define buf-end (core-port-buffer-end in))
|
||||
(cond
|
||||
[(procedure? read-in)
|
||||
(define v (read-in (core-port-self in) bstr start end copy-bstr?))
|
||||
(let result-loop ([v v])
|
||||
(cond
|
||||
[(and (integer? v) (not (eq? v 0)))
|
||||
(port-count-all! in extra-count-ins v bstr start)]
|
||||
[(procedure? v)
|
||||
(port-count-byte-all! in extra-count-ins #f)])
|
||||
(end-atomic)
|
||||
(cond
|
||||
[(exact-nonnegative-integer? v)
|
||||
(cond
|
||||
[(zero? v)
|
||||
(if zero-ok?
|
||||
0
|
||||
(loop in extra-count-ins))]
|
||||
[(v . <= . (- end start)) v]
|
||||
[else
|
||||
(raise-arguments-error who
|
||||
"result integer is larger than the supplied byte string"
|
||||
"result" v
|
||||
"byte-string length" (- end start))])]
|
||||
[(eof-object? v) eof]
|
||||
[(evt? v)
|
||||
;; If `zero-ok?`, we should at least poll the event
|
||||
(define timeout (if zero-ok? (lambda () 0) #f))
|
||||
(define next-v (if enable-break?
|
||||
(sync/timeout/enable-break timeout v)
|
||||
(sync/timeout timeout v)))
|
||||
(cond
|
||||
[(and zero-ok? (evt? next-v))
|
||||
;; Avoid looping on events
|
||||
0]
|
||||
[else
|
||||
(start-atomic)
|
||||
(result-loop next-v)])]
|
||||
[(procedure? v)
|
||||
(if special-ok?
|
||||
(if limit-special-arity?
|
||||
(lambda (a b c d) (v a b c d))
|
||||
v)
|
||||
(raise-arguments-error who
|
||||
"non-character in an unsupported context"
|
||||
"port" orig-in))]
|
||||
[else
|
||||
(internal-error (format "weird read-bytes result ~s" v))]))]
|
||||
[else
|
||||
[(buf-pos . < . buf-end)
|
||||
;; Read bytes from buffer
|
||||
(define v (min (- buf-end buf-pos) (- end start)))
|
||||
(define new-pos (fx+ buf-pos v))
|
||||
(bytes-copy! bstr start (core-port-buffer in) buf-pos new-pos)
|
||||
(set-core-port-buffer-pos! in new-pos)
|
||||
(end-atomic)
|
||||
(loop (->core-input-port read-in) (cons in extra-count-ins))])])))
|
||||
v]
|
||||
[else
|
||||
;; Call port's `read-in` method
|
||||
(define read-in (method core-input-port in read-in))
|
||||
(cond
|
||||
[(procedure? read-in)
|
||||
(define v (read-in in bstr start end copy-bstr?))
|
||||
(let result-loop ([v v])
|
||||
(cond
|
||||
[(and (integer? v) (not (eq? v 0)))
|
||||
(port-count-all! in extra-count-ins v bstr start)]
|
||||
[(procedure? v)
|
||||
(port-count-byte-all! in extra-count-ins #f)])
|
||||
(end-atomic)
|
||||
(cond
|
||||
[(exact-nonnegative-integer? v)
|
||||
(cond
|
||||
[(zero? v)
|
||||
(if zero-ok?
|
||||
0
|
||||
(loop in extra-count-ins))]
|
||||
[(v . <= . (- end start)) v]
|
||||
[else
|
||||
(raise-arguments-error who
|
||||
"result integer is larger than the supplied byte string"
|
||||
"result" v
|
||||
"byte-string length" (- end start))])]
|
||||
[(eof-object? v) eof]
|
||||
[(evt? v)
|
||||
;; If `zero-ok?`, we should at least poll the event
|
||||
(define timeout (if zero-ok? (lambda () 0) #f))
|
||||
(define next-v (if enable-break?
|
||||
(sync/timeout/enable-break timeout v)
|
||||
(sync/timeout timeout v)))
|
||||
(cond
|
||||
[(and zero-ok? (evt? next-v))
|
||||
;; Avoid looping on events
|
||||
0]
|
||||
[else
|
||||
(start-atomic)
|
||||
(result-loop next-v)])]
|
||||
[(procedure? v)
|
||||
(if special-ok?
|
||||
(if limit-special-arity?
|
||||
(lambda (a b c d) (v a b c d))
|
||||
v)
|
||||
(raise-arguments-error who
|
||||
"non-character in an unsupported context"
|
||||
"port" orig-in))]
|
||||
[else
|
||||
(internal-error (format "weird read-bytes result ~s" v))]))]
|
||||
[else
|
||||
(end-atomic)
|
||||
(loop (->core-input-port read-in) (cons in extra-count-ins))])])])))
|
||||
|
||||
;; Like `read-some-bytes!`, but merely peeks
|
||||
(define (peek-some-bytes! who orig-in bstr start end skip
|
||||
|
|
@ -129,77 +143,76 @@
|
|||
(sync/timeout 0 progress-evt))
|
||||
(end-atomic)
|
||||
0]
|
||||
[(closed-state-closed? (core-port-closed in))
|
||||
[(core-port-closed? in)
|
||||
(check-not-closed who in)]
|
||||
;; previously detected EOF? (never skip past it)
|
||||
[(core-input-port-pending-eof? in)
|
||||
(end-atomic)
|
||||
|
||||
eof]
|
||||
[else
|
||||
(define peek-in (core-input-port-peek-in in))
|
||||
(define buf-pos (+ (core-port-buffer-pos in) skip))
|
||||
(define buf-end (core-port-buffer-end in))
|
||||
(cond
|
||||
[(procedure? peek-in)
|
||||
(define v (peek-in (core-port-self in) bstr start end skip progress-evt copy-bstr?))
|
||||
[(buf-pos . < . buf-end)
|
||||
;; Copy bytes from buffer
|
||||
(define v (min (- buf-end buf-pos) (- end start)))
|
||||
(bytes-copy! bstr start (core-port-buffer in) buf-pos (fx+ buf-pos v))
|
||||
(end-atomic)
|
||||
(let result-loop ([v v])
|
||||
(cond
|
||||
[(exact-nonnegative-integer? v)
|
||||
(cond
|
||||
[(zero? v)
|
||||
(if zero-ok?
|
||||
0
|
||||
(loop in))]
|
||||
[(v . <= . (- end start)) v]
|
||||
[else
|
||||
(raise-arguments-error who
|
||||
"result integer is larger than the supplied byte string"
|
||||
"result" v
|
||||
"byte-string length" (- end start))])]
|
||||
[(eof-object? v) eof]
|
||||
[(evt? v)
|
||||
(cond
|
||||
[zero-ok? 0]
|
||||
[else (result-loop (if enable-break?
|
||||
(sync/enable-break v)
|
||||
(sync v)))])]
|
||||
[(procedure? v)
|
||||
(if special-ok?
|
||||
(if limit-special-arity?
|
||||
(lambda (a b c d) (v a b c d))
|
||||
v)
|
||||
(raise-arguments-error who
|
||||
"non-character in an unsupported context"
|
||||
"port" orig-in))]
|
||||
[else
|
||||
(internal-error (format "weird peek-bytes result ~s" v))]))]
|
||||
v]
|
||||
[else
|
||||
(end-atomic)
|
||||
(loop (->core-input-port peek-in))])])))
|
||||
(define peek-in (method core-input-port in peek-in))
|
||||
(cond
|
||||
[(procedure? peek-in)
|
||||
(define v (peek-in in bstr start end skip progress-evt copy-bstr?))
|
||||
(end-atomic)
|
||||
(let result-loop ([v v])
|
||||
(cond
|
||||
[(exact-nonnegative-integer? v)
|
||||
(cond
|
||||
[(zero? v)
|
||||
(if zero-ok?
|
||||
0
|
||||
(loop in))]
|
||||
[(v . <= . (- end start)) v]
|
||||
[else
|
||||
(raise-arguments-error who
|
||||
"result integer is larger than the supplied byte string"
|
||||
"result" v
|
||||
"byte-string length" (- end start))])]
|
||||
[(eof-object? v) eof]
|
||||
[(evt? v)
|
||||
(cond
|
||||
[zero-ok? 0]
|
||||
[else (result-loop (if enable-break?
|
||||
(sync/enable-break v)
|
||||
(sync v)))])]
|
||||
[(procedure? v)
|
||||
(if special-ok?
|
||||
(if limit-special-arity?
|
||||
(lambda (a b c d) (v a b c d))
|
||||
v)
|
||||
(raise-arguments-error who
|
||||
"non-character in an unsupported context"
|
||||
"port" orig-in))]
|
||||
[else
|
||||
(internal-error (format "weird peek-bytes result ~s" v))]))]
|
||||
[else
|
||||
(end-atomic)
|
||||
(loop (->core-input-port peek-in))])])])))
|
||||
|
||||
|
||||
;; Use a `read-byte` shortcut
|
||||
(define (do-read-byte who read-byte in)
|
||||
(let loop ()
|
||||
(start-atomic)
|
||||
(prepare-change in)
|
||||
(cond
|
||||
[(closed-state-closed? (core-port-closed in))
|
||||
(check-not-closed who in)]
|
||||
[else
|
||||
(define b (read-byte (core-port-self in)))
|
||||
(cond
|
||||
[(eof-object? b)
|
||||
(end-atomic)
|
||||
b]
|
||||
[(fixnum? b)
|
||||
(port-count-byte! in b)
|
||||
(end-atomic)
|
||||
b]
|
||||
[else ; must be an evt
|
||||
(end-atomic)
|
||||
(sync b)
|
||||
(loop)])])))
|
||||
;; Try the buffer shortcut first
|
||||
(define (read-a-byte who in #:special-ok? [special-ok? #f])
|
||||
(start-atomic)
|
||||
(define pos (core-port-buffer-pos in))
|
||||
(cond
|
||||
[(pos . fx< . (core-port-buffer-end in))
|
||||
(define b (bytes-ref (core-port-buffer in) pos))
|
||||
(set-core-port-buffer-pos! in (fx+ pos 1))
|
||||
(end-atomic)
|
||||
b]
|
||||
[else
|
||||
(end-atomic)
|
||||
(read-byte-via-bytes in #:special-ok? special-ok?)]))
|
||||
|
||||
;; Use the general path; may return a procedure for a special
|
||||
(define (read-byte-via-bytes in #:special-ok? [special-ok? #t])
|
||||
|
|
@ -212,19 +225,18 @@
|
|||
(bytes-ref bstr 0)
|
||||
v))
|
||||
|
||||
;; Use a `peek-byte` shortcut
|
||||
(define (do-peek-byte who peek-byte in)
|
||||
(let loop ()
|
||||
(start-atomic)
|
||||
(prepare-change in)
|
||||
(check-not-closed who in)
|
||||
(define b (peek-byte (core-port-self in)))
|
||||
(end-atomic)
|
||||
(cond
|
||||
[(evt? b)
|
||||
(sync b)
|
||||
(loop)]
|
||||
[else b])))
|
||||
;; Try the buffer shortcut first
|
||||
(define (peek-a-byte who in skip-k #:special-ok? [special-ok? #f])
|
||||
(start-atomic)
|
||||
(define pos (+ (core-port-buffer-pos in) skip-k))
|
||||
(cond
|
||||
[(pos . < . (core-port-buffer-end in))
|
||||
(define b (bytes-ref (core-port-buffer in) pos))
|
||||
(end-atomic)
|
||||
b]
|
||||
[else
|
||||
(end-atomic)
|
||||
(peek-byte-via-bytes in skip-k #:special-ok? special-ok?)]))
|
||||
|
||||
;; Use the general path; may return a procedure for a special
|
||||
(define (peek-byte-via-bytes in skip-k
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"../string/utf-8-decode.rkt"
|
||||
"port.rkt"
|
||||
"input-port.rkt"
|
||||
"read-and-peek.rkt"
|
||||
"bytes-input.rkt"
|
||||
"check.rkt"
|
||||
"prepare-change.rkt")
|
||||
|
|
@ -14,14 +16,14 @@
|
|||
(define/who (byte-ready? in)
|
||||
(check who input-port? in)
|
||||
(let loop ([in (->core-input-port in)])
|
||||
(define byte-ready (core-input-port-byte-ready in))
|
||||
(define byte-ready (method core-input-port in byte-ready))
|
||||
(cond
|
||||
[(input-port? byte-ready) (loop (->core-input-port byte-ready))]
|
||||
[else
|
||||
(start-atomic)
|
||||
(prepare-change in)
|
||||
(check-not-closed who in)
|
||||
(define r (byte-ready (core-port-self in) void))
|
||||
(define r (byte-ready in void))
|
||||
(end-atomic)
|
||||
(eq? #t r)])))
|
||||
|
||||
|
|
@ -30,8 +32,7 @@
|
|||
(let ([in (->core-input-port in)])
|
||||
(cond
|
||||
[(byte-ready? in)
|
||||
(define peek-byte (core-input-port-peek-byte in))
|
||||
(define b (and peek-byte (atomically (peek-byte (core-port-self in)))))
|
||||
(define b (peek-a-byte who in 0))
|
||||
(cond
|
||||
[(and b
|
||||
(or (eof-object? b)
|
||||
|
|
|
|||
|
|
@ -18,13 +18,12 @@
|
|||
(check who input-port? orig-in)
|
||||
(check who #:or-false (procedure-arity-includes/c 1) special-wrap)
|
||||
(let ([in (->core-input-port orig-in)])
|
||||
(define read-byte (core-input-port-read-byte in))
|
||||
(cond
|
||||
[read-byte (do-read-byte who read-byte in)]
|
||||
[else
|
||||
(extract-special-value (read-byte-via-bytes in)
|
||||
in source-name -1
|
||||
special-wrap)])))
|
||||
(define v (read-a-byte who in #:special-ok? #t))
|
||||
(if (fixnum? v)
|
||||
v
|
||||
(extract-special-value v
|
||||
in source-name -1
|
||||
special-wrap))))
|
||||
|
||||
|
||||
(define/who (peek-byte-or-special [orig-in (current-input-port)]
|
||||
|
|
@ -39,9 +38,14 @@
|
|||
(when progress-evt
|
||||
(check-progress-evt who progress-evt orig-in))
|
||||
(let ([in (->core-input-port orig-in)])
|
||||
(define peek-byte (core-input-port-peek-byte in))
|
||||
(cond
|
||||
[peek-byte (do-peek-byte who peek-byte in)]
|
||||
[(not progress-evt)
|
||||
(define v (peek-a-byte who in skip-k #:special-ok? #t))
|
||||
(if (fixnum? v)
|
||||
v
|
||||
(extract-special-value v
|
||||
in source-name skip-k
|
||||
special-wrap))]
|
||||
[else
|
||||
(extract-special-value (peek-byte-via-bytes in skip-k #:progress-evt progress-evt)
|
||||
in source-name skip-k
|
||||
|
|
@ -54,7 +58,7 @@
|
|||
[source-name #f])
|
||||
(let ([in (->core-input-port in who)])
|
||||
(check who #:or-false (procedure-arity-includes/c 1) special-wrap)
|
||||
(extract-special-value (do-read-char/core-port who in #:special-ok? #t)
|
||||
(extract-special-value (read-a-char who in #:special-ok? #t)
|
||||
in source-name -1
|
||||
special-wrap)))
|
||||
|
||||
|
|
@ -65,7 +69,7 @@
|
|||
(check who input-port? in)
|
||||
(check who exact-nonnegative-integer? skip-k)
|
||||
(check who special-wrap-for-peek? #:contract special-wrap-for-peek/c-str special-wrap)
|
||||
(extract-special-value (do-peek-char who in skip-k #:special-ok? #t)
|
||||
(extract-special-value (peek-a-char who in skip-k #:special-ok? #t)
|
||||
in source-name skip-k
|
||||
special-wrap))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "../common/check.rkt"
|
||||
"../common/class.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
"output-port.rkt"
|
||||
|
|
@ -14,13 +15,13 @@
|
|||
(define/who (port-writes-special? o)
|
||||
(check who output-port? o)
|
||||
(let ([o (->core-output-port o)])
|
||||
(and (core-output-port-write-out-special o) #t)))
|
||||
(and (method core-output-port o write-out-special) #t)))
|
||||
|
||||
(define (do-write-special who v orig-o #:retry? retry?)
|
||||
(check who output-port? orig-o)
|
||||
(let port-loop ([o orig-o] [extra-count-os null])
|
||||
(let ([o (->core-output-port o)])
|
||||
(define write-out-special (core-output-port-write-out-special o))
|
||||
(define write-out-special (method core-output-port o write-out-special))
|
||||
(unless write-out-special
|
||||
(raise-arguments-error who
|
||||
"port does not support special values"
|
||||
|
|
@ -31,7 +32,7 @@
|
|||
[else
|
||||
(let loop ()
|
||||
(start-atomic)
|
||||
(define r (write-out-special (core-port-self o) v (not retry?) #f))
|
||||
(define r (write-out-special o v (not retry?) #f))
|
||||
(let result-loop ([r r])
|
||||
(cond
|
||||
[(not r)
|
||||
|
|
@ -57,9 +58,9 @@
|
|||
(define/who (write-special-evt v [o (current-output-port)])
|
||||
(check who output-port? o)
|
||||
(let ([o (->core-output-port o)])
|
||||
(define get-write-special-evt (core-output-port-get-write-special-evt o))
|
||||
(define get-write-special-evt (method core-output-port o get-write-special-evt))
|
||||
(unless get-write-special-evt
|
||||
(raise-arguments-error who
|
||||
"port does not support special-value events"
|
||||
"port" o))
|
||||
(get-write-special-evt (core-port-self o) v)))
|
||||
(get-write-special-evt o v)))
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@
|
|||
peek-string
|
||||
peek-string!
|
||||
|
||||
do-read-char/core-port
|
||||
do-peek-char)
|
||||
read-a-char
|
||||
peek-a-char)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -196,10 +196,11 @@
|
|||
|
||||
;; A shortcut to implement `read-char` in terms of a port-specific
|
||||
;; `read-byte`:
|
||||
(define (read-char-via-read-byte who in read-byte #:special-ok? [special-ok? #t])
|
||||
(define b (do-read-byte who read-byte in))
|
||||
(define (read-char-via-read-byte who in #:special-ok? [special-ok? #t])
|
||||
(define b (read-a-byte who in #:special-ok? special-ok?))
|
||||
(cond
|
||||
[(eof-object? b) b]
|
||||
[(and special-ok? (procedure? b)) b]
|
||||
[else
|
||||
(cond
|
||||
[(b . fx< . 128) (integer->char b)]
|
||||
|
|
@ -217,7 +218,7 @@
|
|||
;; complete, and consume only the already-consumed byte
|
||||
;; if there's a decoding error
|
||||
(let loop ([skip-k 0] [accum accum] [remaining remaining])
|
||||
(define b (peek-byte/core-port in skip-k))
|
||||
(define b (peek-a-byte who in skip-k))
|
||||
(cond
|
||||
[(eof-object? b)
|
||||
;; Already-consumed byte is consume as an error byte
|
||||
|
|
@ -229,7 +230,7 @@
|
|||
[(eq? state 'complete)
|
||||
;; Consume used bytes
|
||||
(let loop ([skip-k skip-k])
|
||||
(do-read-byte who read-byte in)
|
||||
(read-a-byte who in)
|
||||
(unless (fx= 0 skip-k)
|
||||
(loop (fx- skip-k 1))))
|
||||
(integer->char next-accum)]
|
||||
|
|
@ -241,22 +242,12 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
;; If `special-ok?`, can return a special-value procedure
|
||||
(define (do-read-char/core-port who in #:special-ok? [special-ok? #f])
|
||||
(define read-byte (core-input-port-read-byte in))
|
||||
(cond
|
||||
[(not read-byte)
|
||||
(define str (make-string 1))
|
||||
(define-values (v used-bytes) (read-some-chars! who in str 0 1 #:special-ok? special-ok?))
|
||||
(if (eq? v 1)
|
||||
(string-ref str 0)
|
||||
v)]
|
||||
[else
|
||||
;; Byte-level shortcut is available, so try it as a char shortcut
|
||||
(read-char-via-read-byte who in read-byte #:special-ok? special-ok?)]))
|
||||
(define (read-a-char who in #:special-ok? [special-ok? #f])
|
||||
(read-char-via-read-byte who in #:special-ok? special-ok?))
|
||||
|
||||
(define/who (read-char [in (current-input-port)])
|
||||
(let ([in (->core-input-port in who)])
|
||||
(do-read-char/core-port who in)))
|
||||
(read-a-char who in)))
|
||||
|
||||
(define/who (read-string amt [in (current-input-port)])
|
||||
(check who exact-nonnegative-integer? amt)
|
||||
|
|
@ -287,18 +278,17 @@
|
|||
(define (do-peek-string! who in str start end skip #:special-ok? [special-ok? #f])
|
||||
(do-read-string! who in str start end #:skip skip #:just-peek? #t #:special-ok? special-ok?))
|
||||
|
||||
(define (do-peek-char who in skip-k #:special-ok? [special-ok? #f])
|
||||
(define (peek-a-char who in skip-k #:special-ok? [special-ok? #f])
|
||||
(let ([in (->core-input-port in)])
|
||||
(define peek-byte (and (zero? skip-k)
|
||||
(core-input-port-peek-byte in)))
|
||||
(define b (and peek-byte (atomically (peek-byte (core-port-self in)))))
|
||||
(define b (peek-a-byte who in skip-k #:special-ok? special-ok?))
|
||||
(cond
|
||||
[(and b
|
||||
(or (eof-object? b)
|
||||
(and (byte? b)
|
||||
(b . < . 128))))
|
||||
;; Shortcut worked
|
||||
(if (eof-object? b) b (integer->char b))]
|
||||
(b . < . 128))
|
||||
(procedure? b)))
|
||||
;; Shortcut workedx
|
||||
(if (fixnum? b) (integer->char b) b)]
|
||||
[else
|
||||
;; General mode
|
||||
(define bstr (make-string 1))
|
||||
|
|
@ -310,7 +300,7 @@
|
|||
(define/who (peek-char [in (current-input-port)] [skip-k 0])
|
||||
(check who input-port? in)
|
||||
(check who exact-nonnegative-integer? skip-k)
|
||||
(do-peek-char who in skip-k #:special-ok? #f))
|
||||
(peek-a-char who in skip-k #:special-ok? #f))
|
||||
|
||||
(define/who (peek-string amt skip-k [in (current-input-port)])
|
||||
(check who exact-nonnegative-integer? amt)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/fixnum
|
||||
"../common/class.rkt"
|
||||
"../common/internal-error.rkt"
|
||||
"../host/thread.rkt"
|
||||
"port.rkt"
|
||||
|
|
@ -22,10 +23,10 @@
|
|||
(end-atomic)
|
||||
0]
|
||||
[else
|
||||
(define write-out (core-output-port-write-out out))
|
||||
(define write-out (method core-output-port out write-out))
|
||||
(cond
|
||||
[(procedure? write-out)
|
||||
(define v (write-out (core-port-self out) bstr start end (not buffer-ok?) enable-break? copy-bstr?))
|
||||
(define v (write-out out bstr start end (not buffer-ok?) enable-break? copy-bstr?))
|
||||
(let result-loop ([v v])
|
||||
(cond
|
||||
[(not v)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user