From 780c190d69d5a7a484f2aceae2aa926a651d762f Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 28 Jun 2010 21:51:49 -0700
Subject: [PATCH] new vocab windows.streams: COM IStream wrapper for factor
 streams

---
 basis/windows/com/com.factor         |  10 ++-
 basis/windows/streams/platforms.txt  |   1 +
 basis/windows/streams/streams.factor | 112 +++++++++++++++++++++++++++
 basis/windows/streams/summary.txt    |   1 +
 4 files changed, 123 insertions(+), 1 deletion(-)
 create mode 100644 basis/windows/streams/platforms.txt
 create mode 100644 basis/windows/streams/streams.factor
 create mode 100644 basis/windows/streams/summary.txt

diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor
index b69189786f..46ae1ae154 100644
--- a/basis/windows/com/com.factor
+++ b/basis/windows/com/com.factor
@@ -48,6 +48,12 @@ STRUCT: STATSTG
     { grfStateBits DWORD }
     { reserved DWORD } ;
 
+CONSTANT: STGM_READ 0
+CONSTANT: STGM_WRITE 1
+CONSTANT: STGM_READWRITE 2
+
+CONSTANT: STG_E_INVALIDFUNCTION HEX: 80030001
+
 CONSTANT: STGTY_STORAGE   1
 CONSTANT: STGTY_STREAM    2
 CONSTANT: STGTY_LOCKBYTES 3
@@ -61,10 +67,12 @@ CONSTANT: LOCK_WRITE     1
 CONSTANT: LOCK_EXCLUSIVE 2
 CONSTANT: LOCK_ONLYONCE  4
 
+CONSTANT: GUID_NULL GUID: {00000000-0000-0000-0000-000000000000}
+
 COM-INTERFACE: IStream ISequentialStream {0000000C-0000-0000-C000-000000000046}
     HRESULT Seek ( LARGE_INTEGER dlibMove, DWORD dwOrigin, ULARGE_INTEGER* plibNewPosition )
     HRESULT SetSize ( ULARGE_INTEGER* libNewSize )
-    HRESULT CopyTo ( IStream* pstm, ULARGE_INTEGER* cb, ULARGE_INTEGER* pcbRead, ULARGE_INTEGER* pcbWritten )
+    HRESULT CopyTo ( IStream* pstm, ULARGE_INTEGER cb, ULARGE_INTEGER* pcbRead, ULARGE_INTEGER* pcbWritten )
     HRESULT Commit ( DWORD grfCommitFlags )
     HRESULT Revert ( )
     HRESULT LockRegion ( ULARGE_INTEGER libOffset, ULARGE_INTEGER cb, DWORD dwLockType )
diff --git a/basis/windows/streams/platforms.txt b/basis/windows/streams/platforms.txt
new file mode 100644
index 0000000000..3646795db5
--- /dev/null
+++ b/basis/windows/streams/platforms.txt
@@ -0,0 +1 @@
+windows
diff --git a/basis/windows/streams/streams.factor b/basis/windows/streams/streams.factor
new file mode 100644
index 0000000000..f16fe5a927
--- /dev/null
+++ b/basis/windows/streams/streams.factor
@@ -0,0 +1,112 @@
+USING: accessors alien.c-types 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 <direct-uchar-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 ;
+
+:: IStream-stat ( stream out-stat stat-flag -- hresult )
+    [
+        out-stat
+            f >>pwcsName
+            STGTY_STREAM >>type
+            0 >>cbSize
+            FILETIME <struct> >>mtime
+            FILETIME <struct> >>ctime
+            FILETIME <struct> >>atime
+            STGM_READWRITE >>grfMode
+            0 >>grfLocksSupported
+            GUID_NULL >>clsid
+            0 >>grfStateBits
+            0 >>reserved
+    ] with-hresult ;
+
+:: IStream-clone ( out-clone-stream -- hresult )
+    f out-clone-stream 0 void* set-alien-value
+    STG_E_INVALIDFUNCTION ;
+
+MEMO: stream-wrapper ( -- 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 ;
diff --git a/basis/windows/streams/summary.txt b/basis/windows/streams/summary.txt
new file mode 100644
index 0000000000..3578124ca3
--- /dev/null
+++ b/basis/windows/streams/summary.txt
@@ -0,0 +1 @@
+IStream interface wrapper for Factor stream objects
-- 
2.34.1