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

fix bootstrap errors on windows

db4
Doug Coleman 2008-04-28 16:30:11 -05:00
parent 2e07897cfc
commit 0a99342f2b
2 changed files with 228 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
extra/windows/com/syntax/syntax.factor
View File

@ -1,92 +1,92 @@
USING: alien alien.c-types kernel windows.ole32 combinators.lib USING: alien alien.c-types kernel windows.ole32 combinators.lib
parser splitting sequences.lib sequences namespaces assocs parser splitting sequences.lib sequences namespaces assocs
quotations shuffle accessors words macros alien.syntax fry ; quotations shuffle accessors words macros alien.syntax fry ;
IN: windows.com.syntax IN: windows.com.syntax
<PRIVATE <PRIVATE
C-STRUCT: com-interface C-STRUCT: com-interface
{ "void*" "vtbl" } ; { "void*" "vtbl" } ;
MACRO: com-invoke ( n return parameters -- ) MACRO: com-invoke ( n return parameters -- )
dup length -roll dup length -roll
'[ '[
, npick com-interface-vtbl , swap void*-nth , , , npick com-interface-vtbl , swap void*-nth , ,
"stdcall" alien-indirect "stdcall" alien-indirect
] ; ] ;
TUPLE: com-interface-definition name parent iid functions ; TUPLE: com-interface-definition name parent iid functions ;
C: <com-interface-definition> com-interface-definition C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ; TUPLE: com-function-definition name return parameters ;
C: <com-function-definition> com-function-definition C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+ SYMBOL: +com-interface-definitions+
+com-interface-definitions+ get-global +com-interface-definitions+ get-global
[ H{ } +com-interface-definitions+ set-global ] [ H{ } +com-interface-definitions+ set-global ]
unless unless
: find-com-interface-definition ( name -- definition ) : find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [ dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at* dup +com-interface-definitions+ get-global at*
[ nip ] [ nip ]
[ swap " COM interface hasn't been defined" append throw ] [ swap " COM interface hasn't been defined" append throw ]
if if
] if ; ] if ;
: save-com-interface-definition ( definition -- ) : save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ; dup name>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition ) : (parse-com-function) ( tokens -- definition )
[ second ] [ second ]
[ first ] [ first ]
[ 3 tail 2 group [ first ] map "void*" prefix ] [ 3 tail 2 group [ first ] map "void*" prefix ]
tri tri
<com-function-definition> ; <com-function-definition> ;
: parse-com-functions ( -- functions ) : parse-com-functions ( -- functions )
";" parse-tokens { ")" } split ";" parse-tokens { ")" } split
[ empty? not ] filter [ empty? not ] filter
[ (parse-com-function) ] map ; [ (parse-com-function) ] map ;
: (iid-word) ( definition -- word ) : (iid-word) ( definition -- word )
name>> "-iid" append create-in ; name>> "-iid" append create-in ;
: (function-word) ( function interface -- word ) : (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ; name>> "::" rot name>> 3append create-in ;
: family-tree ( definition -- definitions ) : family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if* dup parent>> [ family-tree ] [ { } ] if*
swap add ; swap suffix ;
: family-tree-functions ( definition -- functions ) : family-tree-functions ( definition -- functions )
dup parent>> [ family-tree-functions ] [ { } ] if* dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ; swap functions>> append ;
: (define-word-for-function) ( function interface n -- ) : (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop -rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots { return>> parameters>> } get-slots
[ com-invoke ] 3curry [ com-invoke ] 3curry
define ; define ;
: define-words-for-com-interface ( definition -- ) : define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ] [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
[ name>> "com-interface" swap typedef ] [ name>> "com-interface" swap typedef ]
[ [
dup family-tree-functions dup family-tree-functions
[ (define-word-for-function) ] with each-index [ (define-word-for-function) ] with each-index
] ]
tri ; tri ;
PRIVATE> PRIVATE>
: COM-INTERFACE: : COM-INTERFACE:
scan scan
scan find-com-interface-definition scan find-com-interface-definition
scan string>guid scan string>guid
parse-com-functions parse-com-functions
<com-interface-definition> <com-interface-definition>
dup save-com-interface-definition dup save-com-interface-definition
define-words-for-com-interface define-words-for-com-interface
; parsing ; parsing

271
extra/windows/ole32/ole32.factor
View File

@ -1,135 +1,136 @@
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 combinators.lib ; kernel sequences windows windows.types combinators.lib
IN: windows.ole32 math.order ;
IN: windows.ole32
LIBRARY: ole32
LIBRARY: ole32
TYPEDEF: GUID* REFGUID
TYPEDEF: void* LPUNKNOWN TYPEDEF: GUID* REFGUID
TYPEDEF: wchar_t* LPOLESTR TYPEDEF: void* LPUNKNOWN
TYPEDEF: wchar_t* LPCOLESTR TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ; FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ; FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: S_OK 0 ; inline
: S_FALSE 1 ; inline : S_OK 0 ; inline
: E_NOINTERFACE HEX: 80004002 ; inline : S_FALSE 1 ; inline
: E_FAIL HEX: 80004005 ; inline : E_NOINTERFACE HEX: 80004002 ; inline
: E_INVALIDARG HEX: 80070057 ; inline : E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: MK_ALT HEX: 20 ; inline
: DROPEFFECT_NONE 0 ; inline : MK_ALT HEX: 20 ; inline
: DROPEFFECT_COPY 1 ; inline : DROPEFFECT_NONE 0 ; inline
: DROPEFFECT_MOVE 2 ; inline : DROPEFFECT_COPY 1 ; inline
: DROPEFFECT_LINK 4 ; inline : DROPEFFECT_MOVE 2 ; inline
: DROPEFFECT_SCROLL HEX: 80000000 ; inline : DROPEFFECT_LINK 4 ; inline
: DD_DEFSCROLLINSET 11 ; inline : DROPEFFECT_SCROLL HEX: 80000000 ; inline
: DD_DEFSCROLLDELAY 50 ; inline : DD_DEFSCROLLINSET 11 ; inline
: DD_DEFSCROLLINTERVAL 50 ; inline : DD_DEFSCROLLDELAY 50 ; inline
: DD_DEFDRAGDELAY 200 ; inline : DD_DEFSCROLLINTERVAL 50 ; inline
: DD_DEFDRAGMINDIST 2 ; inline : DD_DEFDRAGDELAY 200 ; inline
: DD_DEFDRAGMINDIST 2 ; inline
: CF_TEXT 1 ; inline
: CF_BITMAP 2 ; inline : CF_TEXT 1 ; inline
: CF_METAFILEPICT 3 ; inline : CF_BITMAP 2 ; inline
: CF_SYLK 4 ; inline : CF_METAFILEPICT 3 ; inline
: CF_DIF 5 ; inline : CF_SYLK 4 ; inline
: CF_TIFF 6 ; inline : CF_DIF 5 ; inline
: CF_OEMTEXT 7 ; inline : CF_TIFF 6 ; inline
: CF_DIB 8 ; inline : CF_OEMTEXT 7 ; inline
: CF_PALETTE 9 ; inline : CF_DIB 8 ; inline
: CF_PENDATA 10 ; inline : CF_PALETTE 9 ; inline
: CF_RIFF 11 ; inline : CF_PENDATA 10 ; inline
: CF_WAVE 12 ; inline : CF_RIFF 11 ; inline
: CF_UNICODETEXT 13 ; inline : CF_WAVE 12 ; inline
: CF_ENHMETAFILE 14 ; inline : CF_UNICODETEXT 13 ; inline
: CF_HDROP 15 ; inline : CF_ENHMETAFILE 14 ; inline
: CF_LOCALE 16 ; inline : CF_HDROP 15 ; inline
: CF_MAX 17 ; inline : CF_LOCALE 16 ; inline
: CF_MAX 17 ; inline
: CF_OWNERDISPLAY HEX: 0080 ; inline
: CF_DSPTEXT HEX: 0081 ; inline : CF_OWNERDISPLAY HEX: 0080 ; inline
: CF_DSPBITMAP HEX: 0082 ; inline : CF_DSPTEXT HEX: 0081 ; inline
: CF_DSPMETAFILEPICT HEX: 0083 ; inline : CF_DSPBITMAP HEX: 0082 ; inline
: CF_DSPENHMETAFILE HEX: 008E ; inline : CF_DSPMETAFILEPICT HEX: 0083 ; inline
: CF_DSPENHMETAFILE HEX: 008E ; inline
: DVASPECT_CONTENT 1 ; inline
: DVASPECT_THUMBNAIL 2 ; inline : DVASPECT_CONTENT 1 ; inline
: DVASPECT_ICON 4 ; inline : DVASPECT_THUMBNAIL 2 ; inline
: DVASPECT_DOCPRINT 8 ; inline : DVASPECT_ICON 4 ; inline
: DVASPECT_DOCPRINT 8 ; inline
: TYMED_HGLOBAL 1 ; inline
: TYMED_FILE 2 ; inline : TYMED_HGLOBAL 1 ; inline
: TYMED_ISTREAM 4 ; inline : TYMED_FILE 2 ; inline
: TYMED_ISTORAGE 8 ; inline : TYMED_ISTREAM 4 ; inline
: TYMED_GDI 16 ; inline : TYMED_ISTORAGE 8 ; inline
: TYMED_MFPICT 32 ; inline : TYMED_GDI 16 ; inline
: TYMED_ENHMF 64 ; inline : TYMED_MFPICT 32 ; inline
: TYMED_NULL 0 ; inline : TYMED_ENHMF 64 ; inline
: TYMED_NULL 0 ; inline
C-STRUCT: DVTARGETDEVICE
{ "DWORD" "tdSize" } C-STRUCT: DVTARGETDEVICE
{ "WORD" "tdDriverNameOffset" } { "DWORD" "tdSize" }
{ "WORD" "tdDeviceNameOffset" } { "WORD" "tdDriverNameOffset" }
{ "WORD" "tdPortNameOffset" } { "WORD" "tdDeviceNameOffset" }
{ "WORD" "tdExtDevmodeOffset" } { "WORD" "tdPortNameOffset" }
{ "BYTE[1]" "tdData" } ; { "WORD" "tdExtDevmodeOffset" }
{ "BYTE[1]" "tdData" } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
C-STRUCT: FORMATETC
{ "CLIPFORMAT" "cfFormat" } C-STRUCT: FORMATETC
{ "DVTARGETDEVICE*" "ptd" } { "CLIPFORMAT" "cfFormat" }
{ "DWORD" "dwAspect" } { "DVTARGETDEVICE*" "ptd" }
{ "LONG" "lindex" } { "DWORD" "dwAspect" }
{ "DWORD" "tymed" } ; { "LONG" "lindex" }
TYPEDEF: FORMATETC* LPFORMATETC { "DWORD" "tymed" } ;
TYPEDEF: FORMATETC* LPFORMATETC
C-STRUCT: STGMEDIUM
{ "DWORD" "tymed" } C-STRUCT: STGMEDIUM
{ "void*" "data" } { "DWORD" "tymed" }
{ "LPUNKNOWN" "punkForRelease" } ; { "void*" "data" }
TYPEDEF: STGMEDIUM* LPSTGMEDIUM { "LPUNKNOWN" "punkForRelease" } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
: COINIT_MULTITHREADED 0 ; inline
: COINIT_APARTMENTTHREADED 2 ; inline : COINIT_MULTITHREADED 0 ; inline
: COINIT_DISABLE_OLE1DDE 4 ; inline : COINIT_APARTMENTTHREADED 2 ; inline
: COINIT_SPEED_OVER_MEMORY 8 ; inline : COINIT_DISABLE_OLE1DDE 4 ; inline
: COINIT_SPEED_OVER_MEMORY 8 ; inline
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; 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: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ; : succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
: ole32-error ( hresult -- )
dup succeeded? [ : ole32-error ( hresult -- )
drop dup succeeded? [
] [ (win32-error-string) throw ] if ; drop
] [ (win32-error-string) throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ; : ole-initialize ( -- )
f OleInitialize ole32-error ;
: guid= ( a b -- ? )
IsEqualGUID c-bool> ; : guid= ( a b -- ? )
IsEqualGUID c-bool> ;
: GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline : GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ; : string>guid ( string -- guid )
: guid>string ( guid -- string ) utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep : guid>string ( guid -- string )
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ; GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;