Initial checkin

contrib/win32/clip.factor

@@ -0,0 +1,16 @@
+USING: kernel win32 math namespaces io prettyprint ;
+
+: (enum-clipboard) ( n -- )
+    EnumClipboardFormats win32-error dup 0 > [ dup , (enum-clipboard) ] when ;
+
+: enum-clipboard ( -- seq )
+    [ 0 (enum-clipboard) ] { } make nip ;
+
+0 OpenClipboard win32-error
+GetClipboardOwner drop win32-error
+GetClipboardSequenceNumber drop win32-error
+enum-clipboard
+
+
+! EmptyClipboard
+CloseClipboard drop win32-error

contrib/win32/examples.factor

@@ -0,0 +1,39 @@
+IN: win32
+USING: alien namespaces math io prettyprint kernel ;
+
+SYMBOL: hInst
+SYMBOL: wc
+SYMBOL: className "SimpleWindowClass" className set 
+
+: hello-world
+    f "Hello, world!" "First Application" MB_OK MessageBox ;
+
+
+! : message-loop ( -- )
+    ! message-loop ;
+
+: app2
+    f GetModuleHandle hInst set
+    <WNDCLASSEX>
+    "WNDCLASSEX" c-size over set-WNDCLASSEX-cbSize
+    CS_HREDRAW CS_VREDRAW bitor over set-WNDCLASSEX-style
+    ! [ event-loop ] over set-WNDCLASSEX-lpfnWndProc
+    0 over set-WNDCLASSEX-cbClsExtra
+    0 over set-WNDCLASSEX-cbWndExtra
+    hInst get over set-WNDCLASSEX-hInstance
+    COLOR_WINDOW 1 + over set-WNDCLASSEX-hbrBackground
+    f over set-WNDCLASSEX-lpszMenuName
+    className get over set-WNDCLASSEX-lpszClassName
+    ! ! f IDI_APPLICATION LoadIcon over [ set-WNDCLASSEX-hIcon ] keep set-WNDCLASSEX-hIconSm
+    ! f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
+    ! RegisterClassEx
+    
+    ! 0 className get "Second Application" WS_OVERLAPPEDWINDOW CW_USEDEFAULT CW_USEDEFAULT CW_USEDEFAULT CW_USEDEFAULT f f hInst get f ! CreateWindowEx
+    
+    ! dup SW_SHOWDEFAULT ShowWindow
+    ! dup UpdateWindow
+    ! message-loop
+    
+    
+    ! f GetModuleHandle
+    ;

contrib/win32/kernel32.factor

@@ -0,0 +1,38 @@
+IN: win32
+USING: alien kernel errors ;
+
+LIBRARY: kernel
+
+! FUNCTION: MAKEINTRESOURCEA
+! FUNCTION: MAKEINTRESOURCEW
+
+! : MAKEINTRESOURCE \ MAKEINTRESOURCEW \ MAKEINTRESOURCEA unicode-exec ;
+! #define IS_INTRESOURCE(_r) (((ULONG_PTR)(_r) >> 16) == 0)
+! #define MAKEINTRESOURCEA(i) (LPSTR)((ULONG_PTR)((WORD)(i)))
+! #define MAKEINTRESOURCEW(i) (LPWSTR)((ULONG_PTR)((WORD)(i)))
+
+
+
+FUNCTION: HMODULE GetModuleHandleA ( char* lpModulename ) ;
+FUNCTION: HMODULE GetModuleHandleW ( char* lpModulename ) ;
+
+: GetModuleHandle \ GetModuleHandleW \ GetModuleHandleA unicode-exec ;
+
+
+! FUNCTION: HMODULE GetModuleHandleEx (
+!    DWORD dwFlags,
+!    LPCTSTR lpModulename,
+!    HMODULE* phModule ) ;
+
+
+
+FUNCTION: DWORD GetLastError ( ) ;
+
+: (win32-error) ( id -- string )
+    "char*" f "error_message" [ "int" ] alien-invoke ;
+
+: win32-error ( -- )
+    GetLastError dup 0 = [ (win32-error) throw ] unless drop ;
+
+
+

contrib/win32/load.factor

@@ -0,0 +1,15 @@
+IN: win32
+USING: alien compiler kernel parser sequences words ;
+
+win32? [
+    "user" "user32.dll" "stdcall" add-library
+    "kernel" "kernel32.dll" "stdcall" add-library
+] [
+    ! something with wine here?
+] if
+
+[ "utils.factor" "types.factor" "kernel32.factor" "user32.factor" ]
+
+[ "contrib/win32/" swap append run-file ] each
+
+"win32" words [ try-compile ] each

contrib/win32/types.factor

@@ -0,0 +1,122 @@
+IN: win32
+USE: alien
+
+TYPEDEF: uchar               BYTE
+TYPEDEF: BYTE*               PBYTE
+TYPEDEF: BYTE*               LPBYTE
+TYPEDEF: int                 BOOL
+TYPEDEF: BOOL*               PBOOL
+TYPEDEF: BOOL*               LPBOOL
+TYPEDEF: int                 INT
+TYPEDEF: int*                PINT
+TYPEDEF: int*                LPINT
+TYPEDEF: uint                UINT
+TYPEDEF: uint*               PUINT
+TYPEDEF: long                LONG
+TYPEDEF: long*               LPLONG
+TYPEDEF: float               FLOAT
+TYPEDEF: FLOAT*              PFLOAT
+TYPEDEF: ushort              WORD
+TYPEDEF: WORD*               PWORD
+TYPEDEF: WORD*               LPWORD
+TYPEDEF: ulong               DWORD
+TYPEDEF: long                LONG_PTR
+TYPEDEF: ulong               ULONG_PTR
+TYPEDEF: long*               PLONG_PTR
+TYPEDEF: ulong*              PULONG_PTR
+TYPEDEF: DWORD*              PDWORD
+TYPEDEF: DWORD*              LPDWORD
+TYPEDEF: void*               LPVOID
+TYPEDEF: void*               LPCVOID
+TYPEDEF: char*               LPCSTR
+TYPEDEF: char*               LPCTSTR
+TYPEDEF: WORD                ATOM
+
+
+! TYPEDEF: ushort wchar_t
+! TYPEDEF: ushort* wchar_t*
+! TYPEDEF: wchar_t ushort
+TYPEDEF: ushort LPCWSTR
+
+TYPEDEF: int       HANDLE
+
+TYPEDEF: HANDLE    HGDIOBJ
+TYPEDEF: HANDLE    HKEY
+TYPEDEF: HANDLE*   PHKEY
+TYPEDEF: HANDLE    HACCEL
+TYPEDEF: HANDLE    HBITMAP
+TYPEDEF: HANDLE    HBRUSH
+TYPEDEF: HANDLE    HCOLORSPACE
+TYPEDEF: HANDLE    HDC
+TYPEDEF: HANDLE    HGLRC       ! OpenGL
+TYPEDEF: HANDLE    HDESK
+TYPEDEF: HANDLE    HENHMETAFILE
+TYPEDEF: HANDLE    HFONT
+TYPEDEF: HANDLE    HICON
+TYPEDEF: HANDLE    HMENU
+TYPEDEF: HANDLE    HMETAFILE
+TYPEDEF: HANDLE    HINSTANCE
+TYPEDEF: HINSTANCE HMODULE
+TYPEDEF: HANDLE    HPALETTE
+TYPEDEF: HANDLE    HPEN
+TYPEDEF: HANDLE    HRGN
+TYPEDEF: HANDLE    HRSRC
+TYPEDEF: HANDLE    HSTR
+TYPEDEF: HANDLE    HTASK
+TYPEDEF: HANDLE    HWINSTA
+TYPEDEF: HANDLE    HWND
+TYPEDEF: HANDLE    HKL
+TYPEDEF: HANDLE    HCURSOR
+
+TYPEDEF: RECT* LPRECT
+TYPEDEF: void* PWNDCLASS
+TYPEDEF: void* PWNDCLASSEX
+
+TYPEDEF: void* WNDPROC
+
+! typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM);
+
+BEGIN-STRUCT: WNDCLASS
+    FIELD: UINT style
+    FIELD: WNDPROC lpfnWndProc
+    FIELD: int cbClsExtra
+    FIELD: int cbWndExtra
+    FIELD: HINSTANCE hInstance
+    FIELD: HICON hIcon
+    FIELD: HCURSOR hCursor
+    FIELD: HBRUSH hbrBackground
+    FIELD: LPCTSTR lpszMenuName
+    FIELD: LPCTSTR lpszClassName
+END-STRUCT
+
+BEGIN-STRUCT: WNDCLASSEX
+    FIELD: UINT cbSize
+    FIELD: UINT style
+    FIELD: WNDPROC lpfnWndProc
+    FIELD: int cbClsExtra
+    FIELD: int cbWndExtra
+    FIELD: HINSTANCE hInstance
+    FIELD: HICON hIcon
+    FIELD: HCURSOR hCursor
+    FIELD: HBRUSH hbrBackground
+    FIELD: LPCTSTR lpszMenuName
+    FIELD: LPCTSTR lpszClassName
+    FIELD: HICON hIconSm
+END-STRUCT
+
+BEGIN-STRUCT: RECT
+    FIELD: LONG left
+    FIELD: LONG top
+    FIELD: LONG right
+    FIELD: LONG bottom
+END-STRUCT
+
+BEGIN-STRUCT: PAINTSTRUCT
+    FIELD: HDC  hdc
+    FIELD: BOOL fErase
+    FIELD: RECT rcPaint
+    FIELD: BOOL fRestore
+    FIELD: BOOL fIncUpdate
+    FIELD: BYTE rgbReserved[32]
+END-STRUCT
+

contrib/win32/utils.factor

@@ -0,0 +1,13 @@
+IN: win32
+USING: alien parser namespaces kernel syntax words math io prettyprint ;
+
+SYMBOL: unicode
+f unicode set
+
+: unicode-exec ( unicode-func ascii-func -- func )
+	unicode get [
+		drop execute
+	] [
+		nip execute
+	] if ; inline
+