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

guid, system-info

db4
Doug Coleman 2009-08-29 17:41:08 -05:00
parent 0c37990f53
commit 50a99dcce6
5 changed files with 51 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/calendar/windows/windows.factor
View File

@ -1,6 +1,6 @@
USING: calendar namespaces alien.c-types system USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators windows.errors windows.kernel32 kernel math combinators windows.errors
classes.struct accessors ; accessors classes.struct ;
IN: calendar.windows IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds ) M: windows gmt-offset ( -- hours minutes seconds )

24
basis/windows/kernel32/kernel32.factor
View File

@ -307,13 +307,13 @@ STRUCT: MEMORYSTATUSEX
TYPEDEF: void* LPMEMORYSTATUSEX TYPEDEF: void* LPMEMORYSTATUSEX
C-STRUCT: OSVERSIONINFO STRUCT: OSVERSIONINFO
{ "DWORD" "dwOSVersionInfoSize" } { dwOSVersionInfoSize DWORD }
{ "DWORD" "dwMajorVersion" } { dwMajorVersion DWORD }
{ "DWORD" "dwMinorVersion" } { dwMinorVersion DWORD }
{ "DWORD" "dwBuildNumber" } { dwBuildNumber DWORD }
{ "DWORD" "dwPlatformId" } { dwPlatformId DWORD }
{ { "WCHAR" 128 } "szCSDVersion" } ; { szCSDVersion WCHAR[128] } ;
TYPEDEF: void* LPOSVERSIONINFO TYPEDEF: void* LPOSVERSIONINFO
@ -326,11 +326,11 @@ C-STRUCT: MEMORY_BASIC_INFORMATION
{ "DWORD" "protect" } { "DWORD" "protect" }
{ "DWORD" "type" } ; { "DWORD" "type" } ;
C-STRUCT: GUID STRUCT: GUID
{ "ULONG" "Data1" } { Data1 ULONG }
{ "WORD" "Data2" } { Data2 WORD }
{ "WORD" "Data3" } { Data3 WORD }
{ { "UCHAR" 8 } "Data4" } ; { Data4 UCHAR[8] } ;
/* /*
fBinary :1; fBinary :1;

79
basis/windows/ole32/ole32.factor
View File

@ -1,7 +1,8 @@
USING: alien alien.syntax alien.c-types alien.strings math USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows.errors windows.types io kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32 accessors math.order namespaces make math.parser windows.kernel32
combinators locals specialized-arrays.direct.uchar ; combinators locals specialized-arrays.direct.uchar
literals splitting grouping classes.struct combinators.smart ;
IN: windows.ole32 IN: windows.ole32
LIBRARY: ole32 LIBRARY: ole32
@ -130,60 +131,34 @@ TUPLE: ole32-error code message ;
: guid= ( a b -- ? ) : guid= ( a b -- ? )
[ 16 memory>byte-array ] bi@ = ; [ 16 memory>byte-array ] bi@ = ;
: GUID-STRING-LENGTH ( -- n ) CONSTANT: GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline $[ "{01234567-89ab-cdef-0123-456789abcdef}" length ]
:: (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
: string>guid ( string -- guid ) : string>guid ( string -- guid )
"GUID" <c-object> [ "{-}" split harvest
{ [ first3 [ hex> ] tri@ ]
[ 1 9 [ set-GUID-Data1 ] (guid-section>guid) ] [ 3 tail concat 2 group [ hex> ] B{ } map-as ] bi
[ 10 14 [ set-GUID-Data2 ] (guid-section>guid) ] GUID <struct-boa> ;
[ 15 19 [ set-GUID-Data3 ] (guid-section>guid) ]
[ ]
} 2cleave
GUID-Data4 {
[ 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
: guid>string ( guid -- string ) : guid>string ( guid -- string )
[ [
"{" % { [ "{" ] dip {
[ [ GUID-Data1 ] 8 (guid-section%) "-" % ] [ Data1>> >hex "-" ]
[ [ GUID-Data2 ] 4 (guid-section%) "-" % ] [ Data2>> >hex "-" ]
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ] [ Data3>> >hex "-" ]
[ ] [
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 } cleave
GUID-Data4 { ] "" append-outputs-as ;
[ 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 ;

11
basis/windows/winsock/winsock.factor
View File

@ -377,8 +377,6 @@ FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents,
BOOL fAlertable ) ; BOOL fAlertable ) ;
LIBRARY: mswsock LIBRARY: mswsock
! Not in Windows CE ! Not in Windows CE
@ -388,14 +386,13 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: WSAID_CONNECTEX ( -- GUID ) : WSAID_CONNECTEX ( -- GUID )
"GUID" <c-object> HEX: 25a207b9
HEX: 25a207b9 over set-GUID-Data1 HEX: ddf3
HEX: ddf3 over set-GUID-Data2 HEX: 4660
HEX: 4660 over set-GUID-Data3
B{ B{
HEX: 8e HEX: e9 HEX: 76 HEX: e5 HEX: 8e HEX: e9 HEX: 76 HEX: e5
HEX: 8c HEX: 74 HEX: 06 HEX: 3e HEX: 8c HEX: 74 HEX: 06 HEX: 3e
} over set-GUID-Data4 ; } GUID <struct-boa> ;
: winsock-expected-error? ( n -- ? ) : winsock-expected-error? ( n -- ? )
ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ; ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING 3array member? ;

14
extra/system-info/windows/windows.factor
View File

@ -21,24 +21,24 @@ IN: system-info.windows
system-info dwOemId>> HEX: ffff0000 bitand ; system-info dwOemId>> HEX: ffff0000 bitand ;
: os-version ( -- os-version ) : os-version ( -- os-version )
"OSVERSIONINFO" <c-object> OSVERSIONINFO <struct>
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize OSVERSIONINFO heap-size >>dwOSVersionInfoSize
dup GetVersionEx win32-error=0/f ; dup GetVersionEx win32-error=0/f ;
: windows-major ( -- n ) : windows-major ( -- n )
os-version OSVERSIONINFO-dwMajorVersion ; os-version dwMajorVersion>> ;
: windows-minor ( -- n ) : windows-minor ( -- n )
os-version OSVERSIONINFO-dwMinorVersion ; os-version dwMinorVersion>> ;
: windows-build# ( -- n ) : windows-build# ( -- n )
os-version OSVERSIONINFO-dwBuildNumber ; os-version dwBuildNumber>> ;
: windows-platform-id ( -- n ) : windows-platform-id ( -- n )
os-version OSVERSIONINFO-dwPlatformId ; os-version dwPlatformId>> ;
: windows-service-pack ( -- string ) : windows-service-pack ( -- string )
os-version OSVERSIONINFO-szCSDVersion alien>native-string ; os-version szCSDVersion>> alien>native-string ;
: feature-present? ( n -- ? ) : feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ; IsProcessorFeaturePresent zero? not ;