-USING: accessors alien.c-types alien.data classes.struct\r
-combinators continuations io kernel libc literals locals\r
-sequences specialized-arrays windows.com memoize\r
-windows.com.wrapper windows.kernel32 windows.ole32\r
-windows.types ;\r
-IN: windows.streams\r
-\r
-SPECIALIZED-ARRAY: uchar\r
-\r
-<PRIVATE\r
-\r
-: with-hresult ( quot: ( -- result ) -- result )\r
- [ drop E_FAIL ] recover ; inline\r
-\r
-:: IStream-read ( stream pv cb out-read -- hresult )\r
- [\r
- cb stream stream-read :> buf\r
- buf length :> bytes\r
- pv buf bytes memcpy\r
- out-read [ bytes out-read 0 ULONG set-alien-value ] when\r
-\r
- cb bytes = [ S_OK ] [ S_FALSE ] if\r
- ] with-hresult ; inline\r
-\r
-:: IStream-write ( stream pv cb out-written -- hresult )\r
- [\r
- pv cb uchar <c-direct-array> stream stream-write\r
- out-written [ cb out-written 0 ULONG set-alien-value ] when\r
- S_OK\r
- ] with-hresult ; inline\r
-\r
-: origin>seek-type ( origin -- seek-type )\r
- {\r
- { $ STREAM_SEEK_SET [ seek-absolute ] }\r
- { $ STREAM_SEEK_CUR [ seek-relative ] }\r
- { $ STREAM_SEEK_END [ seek-end ] }\r
- } case ;\r
-\r
-:: IStream-seek ( stream move origin new-position -- hresult )\r
- [\r
- move origin origin>seek-type stream stream-seek\r
- new-position [\r
- stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value\r
- ] when\r
- S_OK\r
- ] with-hresult ; inline\r
-\r
-:: IStream-set-size ( stream new-size -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )\r
- [\r
- cb stream stream-read :> buf\r
- buf length :> bytes\r
- out-read [ bytes out-read 0 ULONG set-alien-value ] when\r
-\r
- other-stream buf bytes out-written IStream::Write\r
- ] with-hresult ; inline\r
-\r
-:: IStream-commit ( stream flags -- hresult )\r
- stream stream-flush S_OK ;\r
-\r
-:: IStream-revert ( stream -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-lock-region ( stream offset cb lock-type -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-unlock-region ( stream offset cb lock-type -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: stream-size ( stream -- size )\r
- stream stream-tell :> old-pos\r
- 0 seek-end stream stream-seek\r
- stream stream-tell :> size\r
- old-pos seek-absolute stream stream-seek\r
- size ;\r
-\r
-:: IStream-stat ( stream out-stat stat-flag -- hresult )\r
- [\r
- out-stat\r
- f >>pwcsName\r
- STGTY_STREAM >>type\r
- stream stream-size >>cbSize\r
- FILETIME <struct> >>mtime\r
- FILETIME <struct> >>ctime\r
- FILETIME <struct> >>atime\r
- STGM_READWRITE >>grfMode\r
- 0 >>grfLocksSupported\r
- GUID_NULL >>clsid\r
- 0 >>grfStateBits\r
- 0 >>reserved\r
- drop\r
- S_OK\r
- ] with-hresult ;\r
-\r
-:: IStream-clone ( stream out-clone-stream -- hresult )\r
- f out-clone-stream 0 void* set-alien-value\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-CONSTANT: stream-wrapper\r
- $[\r
- {\r
- { IStream {\r
- [ IStream-read ]\r
- [ IStream-write ]\r
- [ IStream-seek ]\r
- [ IStream-set-size ]\r
- [ IStream-copy-to ]\r
- [ IStream-commit ]\r
- [ IStream-revert ]\r
- [ IStream-lock-region ]\r
- [ IStream-unlock-region ]\r
- [ IStream-stat ]\r
- [ IStream-clone ]\r
- } }\r
- } <com-wrapper>\r
- ]\r
-\r
-PRIVATE>\r
-\r
-: stream>IStream ( stream -- IStream )\r
- stream-wrapper com-wrap ;\r
+USING: accessors alien.c-types alien.data classes.struct
+combinators continuations io kernel libc literals locals
+sequences specialized-arrays windows.com memoize
+windows.com.wrapper windows.kernel32 windows.ole32
+windows.types ;
+IN: windows.streams
+
+SPECIALIZED-ARRAY: uchar
+
+<PRIVATE
+
+: with-hresult ( quot: ( -- result ) -- result )
+ [ drop E_FAIL ] recover ; inline
+
+:: IStream-read ( stream pv cb out-read -- hresult )
+ [
+ cb stream stream-read :> buf
+ buf length :> bytes
+ pv buf bytes memcpy
+ out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+ cb bytes = [ S_OK ] [ S_FALSE ] if
+ ] with-hresult ; inline
+
+:: IStream-write ( stream pv cb out-written -- hresult )
+ [
+ pv cb uchar <c-direct-array> stream stream-write
+ out-written [ cb out-written 0 ULONG set-alien-value ] when
+ S_OK
+ ] with-hresult ; inline
+
+: origin>seek-type ( origin -- seek-type )
+ {
+ { $ STREAM_SEEK_SET [ seek-absolute ] }
+ { $ STREAM_SEEK_CUR [ seek-relative ] }
+ { $ STREAM_SEEK_END [ seek-end ] }
+ } case ;
+
+:: IStream-seek ( stream move origin new-position -- hresult )
+ [
+ move origin origin>seek-type stream stream-seek
+ new-position [
+ stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
+ ] when
+ S_OK
+ ] with-hresult ; inline
+
+:: IStream-set-size ( stream new-size -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
+ [
+ cb stream stream-read :> buf
+ buf length :> bytes
+ out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+ other-stream buf bytes out-written IStream::Write
+ ] with-hresult ; inline
+
+:: IStream-commit ( stream flags -- hresult )
+ stream stream-flush S_OK ;
+
+:: IStream-revert ( stream -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-lock-region ( stream offset cb lock-type -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-unlock-region ( stream offset cb lock-type -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: stream-size ( stream -- size )
+ stream stream-tell :> old-pos
+ 0 seek-end stream stream-seek
+ stream stream-tell :> size
+ old-pos seek-absolute stream stream-seek
+ size ;
+
+:: IStream-stat ( stream out-stat stat-flag -- hresult )
+ [
+ out-stat
+ f >>pwcsName
+ STGTY_STREAM >>type
+ stream stream-size >>cbSize
+ FILETIME <struct> >>mtime
+ FILETIME <struct> >>ctime
+ FILETIME <struct> >>atime
+ STGM_READWRITE >>grfMode
+ 0 >>grfLocksSupported
+ GUID_NULL >>clsid
+ 0 >>grfStateBits
+ 0 >>reserved
+ drop
+ S_OK
+ ] with-hresult ;
+
+:: IStream-clone ( stream out-clone-stream -- hresult )
+ f out-clone-stream 0 void* set-alien-value
+ STG_E_INVALIDFUNCTION ;
+
+CONSTANT: stream-wrapper
+ $[
+ {
+ { IStream {
+ [ IStream-read ]
+ [ IStream-write ]
+ [ IStream-seek ]
+ [ IStream-set-size ]
+ [ IStream-copy-to ]
+ [ IStream-commit ]
+ [ IStream-revert ]
+ [ IStream-lock-region ]
+ [ IStream-unlock-region ]
+ [ IStream-stat ]
+ [ IStream-clone ]
+ } }
+ } <com-wrapper>
+ ]
+
+PRIVATE>
+
+: stream>IStream ( stream -- IStream )
+ stream-wrapper com-wrap ;
projects / factor.git / blobdiff