diff --git a/library/io/windows/stream.factor b/library/io/windows/stream.factor index 047e43b2a6..889093912d 100644 --- a/library/io/windows/stream.factor +++ b/library/io/windows/stream.factor @@ -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 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 swap in-buffer get do-read-count ] bind ; + +M: win32-stream stream-read ( n stream -- str/f ) + win32-stream-this [ dup 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 ; : ( path -- stream ) - f t win32-open-file make-win32-stream ; + f t win32-open-file make-win32-stream ;