steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up windows.ole3 and fix it for specialized-arrays change

db4
U-SLAVA-DFB8FF805\Slava 2008-12-03 06:38:44 -06:00
parent 90cc92353a
commit 7b380c526e
1 changed files with 44 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
basis/windows/ole32/ole32.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: alien alien.syntax alien.c-types alien.strings math USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows windows.types debugger io accessors kernel sequences windows windows.types debugger io accessors
math.order namespaces make math.parser windows.kernel32 math.order namespaces make math.parser windows.kernel32
combinators ; combinators locals specialized-arrays.uchar ;
IN: windows.ole32 IN: windows.ole32
LIBRARY: ole32 LIBRARY: ole32
@ -134,20 +134,22 @@ M: ole32-error error.
: GUID-STRING-LENGTH : GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: (guid-section>guid) ( guid string start end quot -- ) :: (guid-section>guid) ( string guid start end quot -- )
[ roll subseq hex> swap ] dip call ; inline start end string subseq hex> guid quot call ; inline
: (guid-byte>guid) ( guid string start end byte -- )
[ roll subseq hex> ] dip : (guid-byte>guid) ( string guid start end byte -- )
rot GUID-Data4 set-uchar-nth ; inline start end string subseq hex> guid byte set-nth ; inline
: string>guid ( string -- guid ) : string>guid ( string -- guid )
"GUID" <c-object> [ { "GUID" <c-object> [
{
[ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] [ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ]
[ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] [ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ]
[ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ] [ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
[ ]
} 2cleave
GUID-Data4 8 <direct-uchar-array> {
[ 20 22 0 (guid-byte>guid) ] [ 20 22 0 (guid-byte>guid) ]
[ 22 24 1 (guid-byte>guid) ] [ 22 24 1 (guid-byte>guid) ]
@ -157,19 +159,24 @@ M: ole32-error error.
[ 31 33 5 (guid-byte>guid) ] [ 31 33 5 (guid-byte>guid) ]
[ 33 35 6 (guid-byte>guid) ] [ 33 35 6 (guid-byte>guid) ]
[ 35 37 7 (guid-byte>guid) ] [ 35 37 7 (guid-byte>guid) ]
} 2cleave ] keep ; } 2cleave
] keep ;
: (guid-section%) ( guid quot len -- ) : (guid-section%) ( guid quot len -- )
[ call >hex ] dip CHAR: 0 pad-left % ; inline [ call >hex ] dip CHAR: 0 pad-left % ; inline
: (guid-byte%) ( guid byte -- ) : (guid-byte%) ( guid byte -- )
swap GUID-Data4 uchar-nth >hex 2 swap nth >hex 2 CHAR: 0 pad-left % ; inline
CHAR: 0 pad-left % ; inline
: guid>string ( guid -- string ) : guid>string ( guid -- string )
[ "{" % { [
"{" % {
[ [ GUID-Data1 ] 8 (guid-section%) "-" % ] [ [ GUID-Data1 ] 8 (guid-section%) "-" % ]
[ [ GUID-Data2 ] 4 (guid-section%) "-" % ] [ [ GUID-Data2 ] 4 (guid-section%) "-" % ]
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ] [ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
[ ]
} cleave
GUID-Data4 8 <direct-uchar-array> {
[ 0 (guid-byte%) ] [ 0 (guid-byte%) ]
[ 1 (guid-byte%) "-" % ] [ 1 (guid-byte%) "-" % ]
[ 2 (guid-byte%) ] [ 2 (guid-byte%) ]
@ -178,5 +185,6 @@ M: ole32-error error.
[ 5 (guid-byte%) ] [ 5 (guid-byte%) ]
[ 6 (guid-byte%) ] [ 6 (guid-byte%) ]
[ 7 (guid-byte%) "}" % ] [ 7 (guid-byte%) "}" % ]
} cleave ] "" make ; } cleave
] "" make ;