io: convert make-input-port to object style
Sortof. This is where we especially take advantage of vtable flexibility. The methods of the vtable are really closures, because that's far more convenient for custom ports.
This commit is contained in:
parent
6e85165b3c
commit
c57b52eb70
|
@ -260,40 +260,41 @@
|
||||||
(make-buffer-mode user-buffer-mode)))
|
(make-buffer-mode user-buffer-mode)))
|
||||||
|
|
||||||
(cond
|
(cond
|
||||||
[user-peek-in
|
[user-peek-in
|
||||||
(make-core-input-port
|
(new core-input-port
|
||||||
#:name name
|
#:override
|
||||||
#:self #f
|
([read-in (if (input-port? user-read-in)
|
||||||
#:read-in
|
user-read-in
|
||||||
(if (input-port? user-read-in)
|
read-in)]
|
||||||
user-read-in
|
[peek-in (if (input-port? user-peek-in)
|
||||||
read-in)
|
user-peek-in
|
||||||
#:peek-in
|
peek-in)]
|
||||||
(if (input-port? user-peek-in)
|
[byte-ready (if (input-port? user-peek-in)
|
||||||
user-peek-in
|
user-peek-in
|
||||||
peek-in)
|
byte-ready)]
|
||||||
#:byte-ready
|
[close close]
|
||||||
(if (input-port? user-peek-in)
|
[get-progress-evt (and user-get-progress-evt get-progress-evt)]
|
||||||
user-peek-in
|
[commit (and user-commit commit)]
|
||||||
byte-ready)
|
[get-location get-location]
|
||||||
#:close close
|
[count-lines! count-lines!]
|
||||||
#:get-progress-evt (and user-get-progress-evt get-progress-evt)
|
[file-position file-position]
|
||||||
#:commit (and user-commit commit)
|
[buffer-mode buffer-mode])
|
||||||
#:get-location get-location
|
[name name]
|
||||||
#:count-lines! count-lines!
|
[offset init-offset])]
|
||||||
#:init-offset init-offset
|
[else
|
||||||
#:file-position file-position
|
(new peek-via-read-input-port
|
||||||
#:buffer-mode buffer-mode)]
|
#:override
|
||||||
[else
|
([read-in/inner read-in]
|
||||||
(define-values (port buffer-flusher)
|
[close (values
|
||||||
(open-input-peek-via-read
|
(lambda (self)
|
||||||
#:name name
|
(close self)
|
||||||
#:self #f
|
(send peek-via-read-input-port self close-peek-buffer)))]
|
||||||
#:read-in read-in
|
[get-location get-location]
|
||||||
#:close close
|
[count-lines! count-lines!]
|
||||||
#:get-location get-location
|
[file-position file-position]
|
||||||
#:count-lines! count-lines!
|
[buffer-mode (or buffer-mode
|
||||||
#:init-offset init-offset
|
(case-lambda
|
||||||
#:file-position file-position
|
[(self) (send peek-via-read-input-port self default-buffer-mode)]
|
||||||
#:alt-buffer-mode buffer-mode))
|
[(self mode) (send peek-via-read-input-port self default-buffer-mode mode)]))])
|
||||||
port]))
|
[name name]
|
||||||
|
[offset init-offset])]))
|
||||||
|
|
|
@ -1,14 +1,15 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require "output-port.rkt")
|
(require "../common/class.rkt"
|
||||||
|
"output-port.rkt")
|
||||||
|
|
||||||
(provide open-output-nowhere)
|
(provide open-output-nowhere)
|
||||||
|
|
||||||
|
(class nowhere-output-port #:extends core-output-port
|
||||||
|
(override
|
||||||
|
[write-out-special
|
||||||
|
(lambda (any no-block/buffer? enable-break?)
|
||||||
|
#t)]))
|
||||||
|
|
||||||
(define (open-output-nowhere)
|
(define (open-output-nowhere)
|
||||||
(make-core-output-port #:name 'nowhere
|
(new nowhere-output-port
|
||||||
#:self #f
|
[name 'nowhere]))
|
||||||
#:evt always-evt
|
|
||||||
#:write-out (lambda (self bstr start-k end-k no-block/buffer? enable-break? copy?)
|
|
||||||
(- end-k start-k))
|
|
||||||
#:close void
|
|
||||||
#:write-out-special (lambda (self any no-block/buffer? enable-break?)
|
|
||||||
#t)))
|
|
||||||
|
|
|
@ -67,7 +67,7 @@
|
||||||
;; The return values are the same as documented for
|
;; The return values are the same as documented for
|
||||||
;; `make-output-port`.
|
;; `make-output-port`.
|
||||||
[write-out (lambda (bstr start-k end-k no-block/buffer? enable-break? copy?)
|
[write-out (lambda (bstr start-k end-k no-block/buffer? enable-break? copy?)
|
||||||
(- start-k end-k))]
|
(- end-k start-k))]
|
||||||
|
|
||||||
;; #f or (any no-block/buffer? enable-break? -*> boolean?)
|
;; #f or (any no-block/buffer? enable-break? -*> boolean?)
|
||||||
;; Called in atomic mode.
|
;; Called in atomic mode.
|
||||||
|
|
|
@ -41,7 +41,13 @@
|
||||||
|
|
||||||
[buffer-adjust-pos
|
[buffer-adjust-pos
|
||||||
(lambda (i)
|
(lambda (i)
|
||||||
(- i (fx- end-pos (if buffer buffer-pos pos))))])
|
(- i (fx- end-pos (if buffer buffer-pos pos))))]
|
||||||
|
|
||||||
|
;; in atomic mode
|
||||||
|
[default-buffer-mode
|
||||||
|
(case-lambda
|
||||||
|
[() buffer-mode]
|
||||||
|
[(mode) (set! buffer-mode mode)])])
|
||||||
|
|
||||||
(private
|
(private
|
||||||
;; in atomic mode
|
;; in atomic mode
|
||||||
|
@ -218,8 +224,8 @@
|
||||||
;; in atomic mode
|
;; in atomic mode
|
||||||
[buffer-mode
|
[buffer-mode
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(self) buffer-mode]
|
[() (default-buffer-mode)]
|
||||||
[(self mode) (set! buffer-mode mode)])]
|
[(mode) (default-buffer-mode mode)])]
|
||||||
|
|
||||||
;; in atomic mode
|
;; in atomic mode
|
||||||
[close
|
[close
|
||||||
|
|
Loading…
Reference in New Issue
Block a user