win32-stream-writer is now a <plain-writer>, removed crap, refactored crap
erg
parent
aa6d3feb4a
commit
ebfa4605b2
|
|
@ -19,10 +19,6 @@ SYMBOL: file-size
|
|||
SYMBOL: timeout
|
||||
SYMBOL: cutoff
|
||||
|
||||
|
||||
|
||||
GENERIC: do-write
|
||||
|
||||
: pending-error ( len/status -- len/status )
|
||||
dup [ win32-throw-error ] unless ;
|
||||
|
||||
|
|
@ -39,35 +35,9 @@ GENERIC: do-write
|
|||
: update-timeout ( -- )
|
||||
timeout get [ millis + cutoff set ] when* ;
|
||||
|
||||
: flush-output ( -- )
|
||||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get out-buffer get [ buffer@ ] keep buffer-length
|
||||
f r> WriteFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
|
||||
dup update-file-pointer
|
||||
out-buffer get [ buffer-consume ] keep
|
||||
buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
! : maybe-flush-output ( buffer -- )
|
||||
: maybe-flush-output ( -- )
|
||||
out-buffer get buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
M: integer do-write
|
||||
out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
|
||||
>r ch>string r> >buffer ;
|
||||
|
||||
M: string do-write
|
||||
dup length out-buffer get buffer-capacity <= [
|
||||
out-buffer get >buffer
|
||||
] [
|
||||
dup length out-buffer get buffer-size > [
|
||||
dup length out-buffer get extend-buffer do-write
|
||||
] [ flush-output do-write ] if
|
||||
] if ;
|
||||
|
||||
: fill-input ( -- )
|
||||
! Read
|
||||
: fill-input ( -- )
|
||||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get in-buffer get [ buffer@ ] keep
|
||||
|
|
@ -78,29 +48,65 @@ M: string do-write
|
|||
|
||||
dup in-buffer get n>buffer update-file-pointer ;
|
||||
|
||||
: consume-input ( count -- str )
|
||||
in-buffer get buffer-length zero? [ fill-input ] when
|
||||
in-buffer get buffer-size min
|
||||
dup in-buffer get buffer-first-n
|
||||
swap in-buffer get buffer-consume ;
|
||||
: consume-input ( count buffer -- str )
|
||||
dup buffer-length zero? [ fill-input ] when
|
||||
[ buffer-size min ] keep
|
||||
[ buffer-first-n ] 2keep
|
||||
buffer-consume ;
|
||||
|
||||
: >string-or-f ( sbuf -- str-or-? )
|
||||
dup length 0 > [ >string ] [ drop f ] if ;
|
||||
dup length zero? [ drop f ] [ >string ] if ;
|
||||
|
||||
: do-read-count ( sbuf count -- str )
|
||||
: do-read-count ( buffer sbuf count -- str )
|
||||
#! Keep reading until count is reached or until stream end (f is returned)
|
||||
dup zero? [
|
||||
drop >string
|
||||
drop >string nip
|
||||
] [
|
||||
dup consume-input
|
||||
dup length dup zero? [
|
||||
3drop >string-or-f
|
||||
pick dupd consume-input
|
||||
dup empty? [
|
||||
2drop >string-or-f nip
|
||||
] [
|
||||
>r swap r> - >r swap [ swap nappend ] keep r> do-read-count
|
||||
rot [ nappend ] 2keep
|
||||
>r length - r> swap do-read-count
|
||||
] if
|
||||
] if ;
|
||||
|
||||
|
||||
|
||||
! Write
|
||||
|
||||
: flush-output ( -- )
|
||||
update-timeout [
|
||||
stream get alloc-io-callback init-overlapped >r
|
||||
handle get out-buffer get [ buffer@ ] keep buffer-length
|
||||
f r> WriteFile [ handle-io-error ] unless stop
|
||||
] callcc1 pending-error
|
||||
dup update-file-pointer
|
||||
out-buffer get [ buffer-consume ] keep
|
||||
buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
! : maybe-flush-output ( buffer -- )
|
||||
: maybe-flush-output ( -- )
|
||||
out-buffer get buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
GENERIC: do-write
|
||||
M: integer do-write ( integer -- )
|
||||
out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
|
||||
>r ch>string r> >buffer ;
|
||||
|
||||
M: string do-write ( string -- )
|
||||
dup length out-buffer get buffer-capacity <= [
|
||||
out-buffer get >buffer
|
||||
] [
|
||||
dup length out-buffer get buffer-size > [
|
||||
dup length out-buffer get extend-buffer do-write
|
||||
] [ flush-output do-write ] if
|
||||
] if ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -111,47 +117,38 @@ M: string do-write
|
|||
;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
M: win32-stream stream-write ( str stream -- )
|
||||
win32-stream-this [ do-write ] bind
|
||||
;
|
||||
|
||||
M: win32-stream stream-write1 ( ch stream -- )
|
||||
win32-stream-this [ >fixnum do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-read ( n stream -- str/f )
|
||||
win32-stream-this [ dup <sbuf> swap do-read-count ] bind ;
|
||||
|
||||
M: win32-stream stream-read1 ( stream -- ch/f )
|
||||
win32-stream-this [
|
||||
1 consume-input dup length zero? [ drop f ] when first
|
||||
] bind ;
|
||||
|
||||
M: win32-stream stream-readln ( stream -- str )
|
||||
win32-stream-this [ readln ] bind ;
|
||||
! win32-stream-in-buffer readln ;
|
||||
|
||||
M: win32-stream stream-terpri ( stream -- )
|
||||
win32-stream-this [ CHAR: \n do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-flush ( stream -- )
|
||||
win32-stream-this [ maybe-flush-output ] bind ;
|
||||
|
||||
M: win32-stream stream-close ( stream -- )
|
||||
win32-stream-this [
|
||||
maybe-flush-output
|
||||
handle get CloseHandle drop
|
||||
in-buffer get buffer-free
|
||||
out-buffer get buffer-free
|
||||
] bind
|
||||
;
|
||||
] bind ;
|
||||
|
||||
M: win32-stream stream-read1 ( stream -- ch/f )
|
||||
win32-stream-this [
|
||||
1 in-buffer get consume-input >string-or-f first
|
||||
] bind ;
|
||||
|
||||
M: win32-stream stream-read ( n stream -- str/f )
|
||||
win32-stream-this [ dup <sbuf> swap in-buffer get do-read-count ] bind ;
|
||||
|
||||
M: win32-stream stream-read ( n stream -- str/f )
|
||||
win32-stream-this [ dup <sbuf> swap in-buffer get do-read-count ] bind ;
|
||||
|
||||
|
||||
M: win32-stream stream-flush ( stream -- )
|
||||
win32-stream-this [ maybe-flush-output ] bind ;
|
||||
|
||||
M: win32-stream stream-write1 ( ch stream -- )
|
||||
win32-stream-this [ >fixnum do-write ] bind ;
|
||||
|
||||
M: win32-stream stream-write ( str stream -- )
|
||||
win32-stream-this [ do-write ] bind ;
|
||||
|
||||
|
||||
|
||||
|
||||
M: win32-stream stream-format ( str style stream -- )
|
||||
win32-stream-this [ drop do-write ] bind ;
|
||||
|
||||
M: win32-stream set-timeout ( n stream -- )
|
||||
win32-stream-this [ timeout set ] bind ;
|
||||
|
|
@ -161,9 +158,6 @@ M: win32-stream expire ! not a generic
|
|||
timeout get [ millis cutoff get > [ handle get CancelIo ] when ] when
|
||||
] bind ;
|
||||
|
||||
M: win32-stream with-nested-stream ( quot style stream -- )
|
||||
win32-stream-this [ drop stream get swap with-stream* ] bind ;
|
||||
|
||||
: make-win32-stream ( handle -- stream )
|
||||
[
|
||||
dup f GetFileSize dup -1 = not [
|
||||
|
|
@ -187,5 +181,5 @@ M: win32-stream with-nested-stream ( quot style stream -- )
|
|||
t f win32-open-file make-win32-stream <line-reader> ;
|
||||
|
||||
: <win32-file-writer> ( path -- stream )
|
||||
f t win32-open-file make-win32-stream ;
|
||||
f t win32-open-file make-win32-stream <plain-writer> ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue