blob: eb0f627e19a582223fe55490c04a4d76a2b66fc7 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
\ **
\ ** 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]
|
