rename current string-mangling "char*" to "c-string". char* is now just a boring...

[factor.git] / basis / windows / ole32 / ole32.factor

diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor
old mode 100755 (executable)
new mode 100644 (file)
index 864700c..538a142
--- a/basis/windows/ole32/ole32.factor
+++ b/basis/windows/ole32/ole32.factor
@@ -1,15 +1,17 @@
-USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types debugger io
-accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar ;
+USING: alien alien.syntax alien.c-types alien.data alien.strings
+math kernel sequences windows.errors windows.types io accessors
+math.order namespaces make math.parser windows.kernel32
+combinators locals specialized-arrays literals splitting
+grouping classes.struct combinators.smart ;
+SPECIALIZED-ARRAY: uchar
 IN: windows.ole32
 
 LIBRARY: ole32
 
 TYPEDEF: GUID* REFGUID
 TYPEDEF: void* LPUNKNOWN
-TYPEDEF: wchar_t* LPOLESTR
-TYPEDEF: wchar_t* LPCOLESTR
+TYPEDEF: LPWSTR LPOLESTR
+TYPEDEF: LPWSTR LPCOLESTR
 
 TYPEDEF: REFGUID LPGUID
 TYPEDEF: REFGUID REFIID
@@ -76,29 +78,29 @@ CONSTANT: TYMED_MFPICT   32
 CONSTANT: TYMED_ENHMF    64
 CONSTANT: TYMED_NULL     0
 
-C-STRUCT: DVTARGETDEVICE
-    { "DWORD" "tdSize" }
-    { "WORD" "tdDriverNameOffset" }
-    { "WORD" "tdDeviceNameOffset" }
-    { "WORD" "tdPortNameOffset" }
-    { "WORD" "tdExtDevmodeOffset" }
-    { "BYTE[1]" "tdData" } ;
+STRUCT: DVTARGETDEVICE
+    { tdSize DWORD }
+    { tdDriverNameOffset WORD }
+    { tdDeviceNameOffset WORD }
+    { tdPortNameOffset WORD }
+    { tdExtDevmodeOffset WORD }
+    { tdData BYTE[1] } ;
 
 TYPEDEF: WORD CLIPFORMAT
 TYPEDEF: POINT POINTL
 
-C-STRUCT: FORMATETC
-    { "CLIPFORMAT" "cfFormat" }
-    { "DVTARGETDEVICE*" "ptd" }
-    { "DWORD" "dwAspect" }
-    { "LONG" "lindex" }
-    { "DWORD" "tymed" } ;
+STRUCT: FORMATETC
+    { cfFormat CLIPFORMAT }
+    { ptd DVTARGETDEVICE* }
+    { dwAspect DWORD }
+    { lindex LONG }
+    { tymed DWORD } ;
 TYPEDEF: FORMATETC* LPFORMATETC
 
-C-STRUCT: STGMEDIUM
-    { "DWORD" "tymed" }
-    { "void*" "data" }
-    { "LPUNKNOWN" "punkForRelease" } ;
+STRUCT: STGMEDIUM
+    { tymed DWORD }
+    { data void* }
+    { punkForRelease LPUNKNOWN } ;
 TYPEDEF: STGMEDIUM* LPSTGMEDIUM
 
 CONSTANT: COINIT_MULTITHREADED     0
@@ -109,18 +111,13 @@ CONSTANT: COINIT_SPEED_OVER_MEMORY 8
 FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
 FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
 
-FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
-FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
-FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
-
 : succeeded? ( hresult -- ? )
     0 HEX: 7FFFFFFF between? ;
 
-TUPLE: ole32-error error-code ;
-C: <ole32-error> ole32-error
+TUPLE: ole32-error code message ;
 
-M: ole32-error error.
-    "COM method failed: " print error-code>> n>win32-error-string print ;
+: <ole32-error> ( code -- error )
+    dup n>win32-error-string \ ole32-error boa ;
 
 : ole32-error ( hresult -- )
     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
@@ -131,60 +128,34 @@ M: ole32-error error.
 : guid= ( a b -- ? )
     [ 16 memory>byte-array ] bi@ = ;
 
-: GUID-STRING-LENGTH ( -- n )
-    "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
-
-:: (guid-section>guid) ( string guid start end quot -- )
-    start end string subseq hex> guid quot call ; inline
-
-:: (guid-byte>guid) ( string guid start end byte -- )
-    start end string subseq hex> byte guid set-nth ; inline
+CONSTANT: GUID-STRING-LENGTH
+    $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
 
 : string>guid ( string -- guid )
-    "GUID" <c-object> [
-        {
-            [  1  9 [ set-GUID-Data1 ] (guid-section>guid) ]
-            [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
-            [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
-            [ ]
-        } 2cleave
-
-        GUID-Data4 8 <direct-uchar-array> {
-            [ 20 22 0 (guid-byte>guid) ]
-            [ 22 24 1 (guid-byte>guid) ]
-
-            [ 25 27 2 (guid-byte>guid) ]
-            [ 27 29 3 (guid-byte>guid) ]
-            [ 29 31 4 (guid-byte>guid) ]
-            [ 31 33 5 (guid-byte>guid) ]
-            [ 33 35 6 (guid-byte>guid) ]
-            [ 35 37 7 (guid-byte>guid) ]
-        } 2cleave
-    ] keep ;
-
-: (guid-section%) ( guid quot len -- )
-    [ call >hex ] dip CHAR: 0 pad-head % ; inline
-
-: (guid-byte%) ( guid byte -- )
-    swap nth >hex 2 CHAR: 0 pad-head % ; inline
+    "{-}" split harvest
+    [ first3 [ hex> ] tri@ ]
+    [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
+    GUID <struct-boa> ;
 
 : guid>string ( guid -- string )
     [
-        "{" % {
-            [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
-            [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
-            [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
-            [ ]
+        [ "{" ] dip {
+            [ Data1>> >hex 8 CHAR: 0 pad-head "-" ]
+            [ Data2>> >hex 4 CHAR: 0 pad-head "-" ]
+            [ Data3>> >hex 4 CHAR: 0 pad-head "-" ]
+            [
+                Data4>> [
+                    {
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head "-" ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                        [ >hex 2 CHAR: 0 pad-head ]
+                    } spread
+                ] input<sequence "}"
+            ]
         } cleave
-        GUID-Data4 8 <direct-uchar-array> {
-            [ 0 (guid-byte%) ]
-            [ 1 (guid-byte%) "-" % ]
-            [ 2 (guid-byte%) ]
-            [ 3 (guid-byte%) ]
-            [ 4 (guid-byte%) ]
-            [ 5 (guid-byte%) ]
-            [ 6 (guid-byte%) ]
-            [ 7 (guid-byte%) "}" % ]
-        } cleave
-    ] "" make ;
-
+    ] "" append-outputs-as ;