shithub: 9ficl

ref: 7c76dac1b268038f567939a70a18228e790a5cbc
dir: 9ficl/softcore/win32.fr

\ ** 
\ ** win32.fr
\ ** submitted by Larry Hastings, larry@hastings.org
\ **


S" FICL_PLATFORM_OS" ENVIRONMENT? drop S" WIN32" compare-insensitive 0= [if]


: GetProcAddress ( name-addr name-u hmodule -- address )
	3 \ argumentCount
	0 \ floatArgumentBitfield
	2 \ cstringArgumentBitfield
	(get-proc-address) \ functionAddress
	[
	multicall-calltype-function multicall-returntype-integer or literal \ flags
	]
	multicall ;


: LoadLibrary ( name-addr name-u -- hmodule )
	2 \ argumentCount
	0 \ floatArgumentBitfield
	1 \ cstringArgumentBitfield
	[
	S" LoadLibraryA" kernel32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-integer or literal \ flags
	]
	multicall ;


: FreeLibrary ( hmodule -- success )
	1 \ argumentCount
	0 \ floatArgumentBitfield
	0 \ cstringArgumentBitfield
	[
	S" FreeLibrary" kernel32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-integer or literal \ flags
	]
	multicall ;


: DebugBreak ( -- )
	0 \ argumentCount
	0 \ floatArgumentBitfield
	0 \ cstringArgumentBitfield
	[
	S" DebugBreak" kernel32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-void or literal \ flags
	]
	multicall ;

: OutputDebugString ( addr u -- )
	2 \ argumentCount
	0 \ floatArgumentBitfield
	1 \ cstringArgumentBitfield
	[
	S" OutputDebugStringA" kernel32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-void or literal \ flags
	]
	multicall ;

: GetTickCount ( -- ticks )
	0 \ argumentCount
	0 \ floatArgumentBitfield
	0 \ cstringArgumentBitfield
	[
	S" GetTickCount" kernel32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-integer or literal \ flags
	]
	multicall ;

S" user32.dll" LoadLibrary constant user32.dll

: MessageBox ( flags title-addr title-u body-addr body-u hwnd -- button )
	6 \ argumentCount
	0 \ floatArgumentBitfield
	[
	2 8 or literal \ cstringArgumentBitfield
	S" MessageBoxA" user32.dll GetProcAddress literal \ functionAddress
	multicall-calltype-function multicall-returntype-integer or literal \ flags
	]
	multicall ;


\ Constants for use with MessageBox
\ the ID* names are possible return values.

0x00000000 constant MB_OK
0x00000001 constant MB_OKCANCEL                 
0x00000002 constant MB_ABORTRETRYIGNORE         
0x00000003 constant MB_YESNOCANCEL              
0x00000004 constant MB_YESNO                    
0x00000005 constant MB_RETRYCANCEL              
0x00000010 constant MB_ICONHAND                 
0x00000020 constant MB_ICONQUESTION             
0x00000030 constant MB_ICONEXCLAMATION          
0x00000040 constant MB_ICONASTERISK             
0x00000080 constant MB_USERICON                 
0x00000000 constant MB_DEFBUTTON1               
0x00000100 constant MB_DEFBUTTON2               
0x00000200 constant MB_DEFBUTTON3               
0x00000300 constant MB_DEFBUTTON4               
0x00000000 constant MB_APPLMODAL                
0x00001000 constant MB_SYSTEMMODAL              
0x00002000 constant MB_TASKMODAL                
0x00004000 constant MB_HELP                     
0x00008000 constant MB_NOFOCUS                  
0x00010000 constant MB_SETFOREGROUND            
0x00020000 constant MB_DEFAULT_DESKTOP_ONLY     
0x00040000 constant MB_TOPMOST                  
0x00080000 constant MB_RIGHT                    
0x00100000 constant MB_RTLREADING               

MB_ICONEXCLAMATION constant MB_ICONWARNING              
MB_ICONHAND        constant MB_ICONERROR                
MB_ICONASTERISK    constant MB_ICONINFORMATION          
MB_ICONHAND        constant MB_ICONSTOP                 


0x00200000 constant MB_SERVICE_NOTIFICATION          
0x00040000 constant MB_SERVICE_NOTIFICATION          
0x00040000 constant MB_SERVICE_NOTIFICATION_NT3X     

0x0000000F constant MB_TYPEMASK                 
0x000000F0 constant MB_ICONMASK                 
0x00000F00 constant MB_DEFMASK                  
0x00003000 constant MB_MODEMASK                 
0x0000C000 constant MB_MISCMASK                 


1 constant IDOK                
2 constant IDCANCEL            
3 constant IDABORT             
4 constant IDRETRY             
5 constant IDIGNORE            
6 constant IDYES               
7 constant IDNO                
8 constant IDCLOSE         
9 constant IDHELP          


\ ** old names
: output-debug-string OutputDebugString ;
: debug-break DebugBreak ;


: uaddr->cstring { addr u | cstring -- cstring }
	u 1+  allocate
	0= if
		to cstring
		addr cstring u move
		0  cstring u + c!
		cstring
	else
		0
	endif
	;

\ **
\ ** The following four calls:
\ **    callnativeFunction
\ **    callcFunction
\ **    callpascalFunction
\ **    vcall
\ ** are deprecated.  Please use the more powerful "multicall" instead.
\ **

\ ** My original native function caller, reimplemented in Ficl using multicall.
: callnativeFunction { functionAddress popStack -- }
	0 \ floatArgumentBitfield
	0 \ cstringArgumentBitfield
	functionAddress \ functionAddress

	[
	multicall-calltype-function
	multicall-returntype-integer or
	multicall-reverse-arguments or
	literal
	]

	multicall
	;


\ ** simple wrappers for callnativeFunction that specify the calling convention
: callcfunction 1 callnativeFunction ;
: callpascalfunction 0 callnativeFunction ;


\ ** Guy Carver's "vcall" function, reimplemented in Ficl using multicall.
: vcall { argumentCount index -- }
	argumentCount 0x80000000 invert or  \ cleaned-up argumentCount
	0 \ cstringArgumentBitfield
	0 \ cstringFlags
	index \ index

	\ flags:
	argumentCount 0x80000000 and if multicall-returntype-integer else multicall-returntype-void endif
	
	[
	multicall-calltype-virtual-method
	multicall-reverse-arguments or
	literal
	] or

	multicall
	;

[endif]