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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-09-27 19:28:47 -05:00
parent 705b4ab5c3 f8251d2045
commit d3aa0a538b
14 changed files with 135 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/alien/c-types/c-types-tests.factor Normal file → Executable file
View File

@ -1,50 +1,50 @@
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8
math.constants ;
USING: alien alien.syntax alien.c-types alien.parser
kernel tools.test sequences system libc alien.strings
io.encodings.utf8 math.constants classes.struct ;
IN: alien.c-types.tests
CONSTANT: xyz 123
[ 492 ] [ { "int" xyz } heap-size ] unit-test
[ 492 ] [ { int xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test
C-UNION: foo
"int"
"int" ;
UNION-STRUCT: foo
{ a int }
{ b int } ;
[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test
[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test
[ f ] [ "char*" parse-c-type c-type void* c-type eq? ] unit-test
[ t ] [ "char**" parse-c-type c-type void* c-type eq? ] unit-test
[ t ] [ "foo" heap-size "int" heap-size = ] unit-test
[ t ] [ foo heap-size int heap-size = ] unit-test
TYPEDEF: int MyInt
[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test
[ t ] [ int c-type MyInt c-type eq? ] unit-test
[ t ] [ void* c-type "MyInt*" parse-c-type c-type eq? ] unit-test
TYPEDEF: char MyChar
[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test
[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test
[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test
[ t ] [ char c-type MyChar c-type eq? ] unit-test
[ f ] [ void* c-type "MyChar*" parse-c-type c-type eq? ] unit-test
[ t ] [ "char*" parse-c-type c-type "MyChar*" parse-c-type c-type eq? ] unit-test
[ 32 ] [ { "int" 8 } heap-size ] unit-test
[ 32 ] [ { int 8 } heap-size ] unit-test
TYPEDEF: char* MyString
[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test
[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test
[ t ] [ char* c-type MyString c-type eq? ] unit-test
[ t ] [ void* c-type "MyString*" parse-c-type c-type eq? ] unit-test
TYPEDEF: int* MyIntArray
[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test
[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test
TYPEDEF: uchar* MyLPBYTE
[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>

2
basis/opengl/gl/windows/windows.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: alien.syntax kernel windows.types ;
USING: alien.c-types alien.syntax kernel windows.types ;
IN: opengl.gl.windows
LIBRARY: gl

10
basis/windows/advapi32/advapi32.factor
View File

@ -1,5 +1,5 @@
USING: alien.syntax kernel math windows.types windows.kernel32
math.bitwise classes.struct ;
USING: alien.c-types alien.syntax kernel math windows.types
windows.kernel32 math.bitwise classes.struct ;
IN: windows.advapi32
LIBRARY: advapi32
@ -222,15 +222,15 @@ C-ENUM:
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: TRUSTEE
{ pMultipleTrustee PTRUSTEE }
{ pMultipleTrustee TRUSTEE* }
{ MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION }
{ TrusteeForm TRUSTEE_FORM }
{ TrusteeType TRUSTEE_TYPE }
{ ptstrName LPTSTR } ;
TYPEDEF: TRUSTEE* PTRUSTEE
STRUCT: EXPLICIT_ACCESS
{ grfAccessPermissions DWORD }
{ grfAccessMode ACCESS_MODE }

96
basis/windows/com/com.factor Normal file → Executable file
View File

@ -1,45 +1,51 @@
USING: alien alien.c-types alien.destructors windows.com.syntax
windows.ole32 windows.types continuations kernel alien.syntax
libc destructors accessors alien.data ;
IN: windows.com
LIBRARY: ole32
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
ULONG Release ( ) ;
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT QueryGetData ( FORMATETC* pFormatetc )
HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
HRESULT DUnadvise ( DWORD pdwConnection )
HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragLeave ( )
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
: com-query-interface ( interface iid -- interface' )
[
"void*" malloc-object &free
[ IUnknown::QueryInterface ole32-error ] keep *void*
] with-destructors ;
: com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline
: com-release ( interface -- )
IUnknown::Release drop ; inline
: with-com-interface ( interface quot -- )
over [ com-release ] curry [ ] cleanup ; inline
DESTRUCTOR: com-release
USING: alien alien.c-types alien.destructors windows.com.syntax
windows.ole32 windows.types continuations kernel alien.syntax
libc destructors accessors alien.data ;
IN: windows.com
LIBRARY: ole32
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
ULONG Release ( ) ;
TYPEDEF: void* IAdviseSink*
COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}
HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )
HRESULT QueryGetData ( FORMATETC* pFormatetc )
HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )
HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )
HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )
HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )
HRESULT DUnadvise ( DWORD pdwConnection )
HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;
COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
HRESULT DragLeave ( )
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: com-query-interface ( interface iid -- interface' )
[
"void*" malloc-object &free
[ IUnknown::QueryInterface ole32-error ] keep *void*
] with-destructors ;
: com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline
: com-release ( interface -- )
IUnknown::Release drop ; inline
: with-com-interface ( interface quot -- )
over [ com-release ] curry [ ] cleanup ; inline
DESTRUCTOR: com-release

42
basis/windows/com/syntax/syntax.factor
View File

@ -1,8 +1,8 @@
USING: alien alien.c-types alien.accessors effects kernel
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
macros alien.syntax fry arrays layouts math classes.struct
windows.kernel32 ;
USING: alien alien.c-types alien.accessors alien.parser
effects kernel windows.ole32 parser lexer splitting grouping
sequences namespaces assocs quotations generalizations
accessors words macros alien.syntax fry arrays layouts math
classes.struct windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
@ -14,7 +14,7 @@ MACRO: com-invoke ( n return parameters -- )
"stdcall" alien-indirect
] ;
TUPLE: com-interface-definition name parent iid functions ;
TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
@ -25,22 +25,25 @@ SYMBOL: +com-interface-definitions+
[ H{ } +com-interface-definitions+ set-global ]
unless
ERROR: no-com-interface interface ;
: find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [
[
dup +com-interface-definitions+ get-global at*
[ nip ]
[ " COM interface hasn't been defined" prepend throw ]
if
] if ;
[ nip ] [ drop no-com-interface ] if
] [ f ] if* ;
: save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ;
dup word>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
[ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
tri
[
3 tail [ CHAR: , swap remove ] map
2 group [ first2 normalize-c-arg 2array ] map
{ void* "this" } prefix
] tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
@ -48,10 +51,11 @@ unless
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
name>> "-iid" append create-in ;
word>> name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ;
swap [ word>> name>> "::" ] [ name>> ] bi*
3append create-in ;
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
@ -79,7 +83,7 @@ unless
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
[ name>> "com-interface" swap typedef ]
[ word>> void* swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
@ -89,8 +93,8 @@ unless
PRIVATE>
SYNTAX: COM-INTERFACE:
scan
scan find-com-interface-definition
CREATE-C-TYPE
scan-object find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>

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

@ -1,6 +1,6 @@
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
alien alien.c-types alien.syntax kernel system namespaces math
classes.struct ;
classes.struct windows.types ;
IN: windows.dinput
LIBRARY: dinput

4
basis/windows/gdi32/gdi32.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.destructors kernel windows.types
math.bitwise ;
USING: alien alien.c-types alien.syntax alien.destructors
kernel windows.types math.bitwise ;
IN: windows.gdi32
CONSTANT: BI_RGB 0

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

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel windows.types multiline
classes.struct ;
USING: alien alien.c-types alien.syntax kernel windows.types
multiline classes.struct ;
IN: windows.kernel32
CONSTANT: MAX_PATH 260
@ -543,7 +543,7 @@ STRUCT: DCB
TYPEDEF: DCB* PDCB
TYPEDEF: DCB* LPDCB
STRUCT: COMM_CONFIG
STRUCT: COMMCONFIG
{ dwSize DWORD }
{ wVersion WORD }
{ wReserved WORD }

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

@ -111,10 +111,6 @@ 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? ;

4
basis/windows/shell32/shell32.factor Normal file → Executable file
View File

@ -3,8 +3,8 @@
USING: alien alien.c-types alien.strings alien.syntax
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
windows.com.syntax windows.user32 windows.ole32 windows
specialized-arrays ;
windows.com.syntax windows.types windows.user32
windows.ole32 windows specialized-arrays ;
SPECIALIZED-ARRAY: ushort
IN: windows.shell32

20
basis/windows/types/types.factor
View File

@ -61,6 +61,7 @@ TYPEDEF: ulong ULONG_PTR
TYPEDEF: int INT32
TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32
TYPEDEF: long LONG32
TYPEDEF: ulong ULONG32
TYPEDEF: ulonglong ULONG64
TYPEDEF: long* POINTER_32
@ -75,6 +76,8 @@ TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
TYPEDEF: size_t SIZE_T
TYPEDEF: ptrdiff_t SSIZE_T
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
@ -201,15 +204,6 @@ TYPEDEF: LONG_PTR SSIZE_T
TYPEDEF: LONGLONG USN
TYPEDEF: UINT_PTR WPARAM
TYPEDEF: RECT* LPRECT
TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX
TYPEDEF: void* LPWNDCLASS
TYPEDEF: void* LPWNDCLASSEX
TYPEDEF: void* MSGBOXPARAMSA
TYPEDEF: void* MSGBOXPARAMSW
TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
TYPEDEF: size_t socklen_t
TYPEDEF: void* WNDPROC
@ -343,6 +337,14 @@ TYPEDEF: PFD* LPPFD
TYPEDEF: HANDLE HGLRC
TYPEDEF: HANDLE HRGN
TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX
TYPEDEF: void* LPWNDCLASS
TYPEDEF: void* LPWNDCLASSEX
TYPEDEF: void* MSGBOXPARAMSA
TYPEDEF: void* MSGBOXPARAMSW
TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE
STRUCT: LVITEM
{ mask uint }
{ iItem int }

6
basis/windows/user32/user32.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
windows.types generalizations math.bitwise classes.struct
literals ;
USING: alien alien.c-types alien.syntax parser namespaces
kernel math windows.types generalizations math.bitwise
classes.struct literals windows.kernel32 ;
IN: windows.user32
! HKL for ActivateKeyboardLayout

6
basis/windows/usp10/usp10.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.destructors classes.struct ;
USING: alien.c-types alien.syntax alien.destructors classes.struct
windows.types ;
IN: windows.usp10
LIBRARY: usp10
@ -56,6 +57,9 @@ SCRIPT_JUSTIFFY_RESERVED4 ;
STRUCT: SCRIPT_VISATTR
{ flags WORD } ;
TYPEDEF: void* SCRIPT_CACHE*
TYPEDEF: void* ABC*
FUNCTION: HRESULT ScriptShape (
HDC hdc,
SCRIPT_CACHE* psc,

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

@ -105,6 +105,8 @@ CONSTANT: SD_BOTH 2
CONSTANT: SOL_SOCKET HEX: ffff
TYPEDEF: void* sockaddr*
STRUCT: sockaddr-in
{ family short }
{ port ushort }
@ -139,13 +141,15 @@ STRUCT: timeval
{ sec long }
{ usec long } ;
TYPEDEF: void* fd_set*
LIBRARY: winsock
FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ;
FUNCTION: ushort htons ( ushort n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ;
FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ;
FUNCTION: int listen ( void* socket, int backlog ) ;
FUNCTION: char* inet_ntoa ( int in-addr ) ;
FUNCTION: int getaddrinfo ( char* nodename,
@ -158,15 +162,15 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
FUNCTION: hostent* gethostbyname ( char* name ) ;
FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ;
FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
FUNCTION: int closesocket ( SOCKET s ) ;
FUNCTION: int shutdown ( SOCKET s, int how ) ;
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED