1 /*
2 ** win32.c
3 ** submitted to Ficl by Larry Hastings, larry@hastings.org
4 **/
5
6 #include <sys/stat.h>
7 #include "ficl.h"
8
9
10 /*
11 **
12 ** Heavy, undocumented wizardry here.
13 **
14 ** In Win32, like most OSes, the buffered file I/O functions in the
15 ** C API (functions that take a FILE * like fopen()) are implemented
16 ** on top of the raw file I/O functions (functions that take an int,
17 ** like open()). However, in Win32, these functions in turn are
18 ** implemented on top of the Win32 native file I/O functions (functions
19 ** that take a HANDLE, like CreateFile()). This behavior is undocumented
20 ** but easy to deduce by reading the CRT/SRC directory.
21 **
22 ** The below mishmash of typedefs and defines were copied from
23 ** CRT/SRC/INTERNAL.H from MSVC.
24 **
25 ** --lch
26 */
27 typedef struct {
28 long osfhnd; /* underlying OS file HANDLE */
29 char osfile; /* attributes of file (e.g., open in text mode?) */
30 char pipech; /* one char buffer for handles opened on pipes */
31 #ifdef _MT
32 int lockinitflag;
33 CRITICAL_SECTION lock;
34 #endif /* _MT */
35 } ioinfo;
36 extern _CRTIMP ioinfo * __pioinfo[];
37
38 #define IOINFO_L2E 5
39 #define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
40 #define _pioinfo(i) ( __pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - \
41 1)) )
42 #define _osfhnd(i) ( _pioinfo(i)->osfhnd )
43
44
ficlFileTruncate(ficlFile * ff,ficlUnsigned size)45 int ficlFileTruncate(ficlFile *ff, ficlUnsigned size)
46 {
47 HANDLE hFile = (HANDLE)_osfhnd(_fileno(ff->f));
48 if (SetFilePointer(hFile, size, NULL, FILE_BEGIN) != size)
49 return 0;
50 return !SetEndOfFile(hFile);
51 }
52
53
ficlFileStatus(char * filename,int * status)54 int ficlFileStatus(char *filename, int *status)
55 {
56 /*
57 ** The Windows documentation for GetFileAttributes() says it returns
58 ** INVALID_FILE_ATTRIBUTES on error. There's no such #define. The
59 ** return value for error is -1, so we'll just use that.
60 */
61 DWORD attributes = GetFileAttributes(filename);
62 if (attributes == -1)
63 {
64 *status = GetLastError();
65 return -1;
66 }
67 *status = attributes;
68 return 0;
69 }
70
71
ficlFileSize(ficlFile * ff)72 long ficlFileSize(ficlFile *ff)
73 {
74 struct stat statbuf;
75 if (ff == NULL)
76 return -1;
77
78 statbuf.st_size = -1;
79 if (fstat(fileno(ff->f), &statbuf) != 0)
80 return -1;
81
82 return statbuf.st_size;
83 }
84
85
86
87
88
ficlMalloc(size_t size)89 void *ficlMalloc(size_t size)
90 {
91 return malloc(size);
92 }
93
ficlRealloc(void * p,size_t size)94 void *ficlRealloc(void *p, size_t size)
95 {
96 return realloc(p, size);
97 }
98
ficlFree(void * p)99 void ficlFree(void *p)
100 {
101 free(p);
102 }
103
ficlCallbackDefaultTextOut(ficlCallback * callback,char * message)104 void ficlCallbackDefaultTextOut(ficlCallback *callback, char *message)
105 {
106 FICL_IGNORE(callback);
107 if (message != NULL)
108 fputs(message, stdout);
109 else
110 fflush(stdout);
111 return;
112 }
113
114
115
116 /*
117 **
118 ** Platform-specific functions
119 **
120 */
121
122
123 /*
124 ** m u l t i c a l l
125 **
126 ** The be-all, end-all, swiss-army-chainsaw of native function call methods in Ficl.
127 **
128 ** Usage:
129 ** ( x*argumentCount [this] [vtable] argumentCount floatArgumentBitfield cstringArgumentBitfield functionAddress flags -- returnValue | )
130 ** Note that any/all of the arguments (x*argumentCount) and the return value can use the
131 ** float stack instead of the data stack.
132 **
133 ** To call a simple native function:
134 ** call with flags = MULTICALL_CALLTYPE_FUNCTION
135 ** To call a method on an object:
136 ** pass in the "this" pointer just below argumentCount,
137 ** call with flags = MULTICALL_CALLTYPE_METHOD
138 ** *do not* include the "this" pointer for the purposes of argumentCount
139 ** To call a virtual method on an object:
140 ** pass in the "this" pointer just below argumentCount,
141 ** call with flags = MULTICALL_CALLTYPE_VIRTUAL_METHOD
142 ** *do not* include the "this" pointer for the purposes of argumentCount
143 ** the function address must be the offset into the vtable for that function
144 ** It doesn't matter whether the function you're calling is "stdcall" (caller pops
145 ** the stack) or "fastcall" (callee pops the stack); for robustness, multicall
146 ** always restores the original stack pointer anyway.
147 **
148 **
149 ** To handle floating-point arguments:
150 ** To thunk an argument from the float stack instead of the data stack, set the corresponding bit
151 ** in the "floatArgumentBitfield" argument. Argument zero is bit 0 (1), argument one is bit 1 (2),
152 ** argument 2 is is bit 2 (4), argument 3 is bit 3 (8), etc. For instance, to call this function:
153 ** float greasyFingers(int a, float b, int c, float d)
154 ** you would call
155 ** 4 \ argumentCount
156 ** 2 8 or \ floatArgumentBitfield, thunk argument 2 (2) and 4 (8)
157 ** 0 \ cstringArgumentBitfield, don't thunk any arguments
158 ** (addressOfGreasyFingers) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-FLOAT or multicall
159 **
160 ** To handle automatic conversion of addr-u arguments to C-style strings:
161 ** This is much like handling float arguments. The bit set in cstringArgumentBitfield specifies
162 ** the *length* argument (the higher of the two arguments) for each addr-u you want converted.
163 ** You must count *both* arguments for the purposes of the argumentCount parameter.
164 ** For instance, to call the Win32 function MessageBoxA:
165 **
166 ** 0 "Howdy there!" "Title" 0
167 ** 6 \ argument count is 6! flags text-addr text-u title-addr title-u hwnd
168 ** 0 \ floatArgumentBitfield, don't thunk any float arguments
169 ** 2 8 or \ cstringArgumentBitfield, thunk for title-u (argument 2, 2) and text-u (argument 4, 8)
170 ** (addressOfMessageBoxA) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-INTEGER or multicall
171 ** The strings are copied to temporary storage and appended with a zero. These strings are freed
172 ** before multicall returns. If you need to call functions that write to these string buffers,
173 ** you'll need to handle thunking those arguments yourself.
174 **
175 ** (If you want to call a function with more than 32 parameters, and do thunking, you need to hit somebody
176 ** in the head with a rock. Note: this could be you!)
177 **
178 ** Note that, big surprise, this function is really really really dependent
179 ** on predefined behavior of Win32 and MSVC. It would be non-zero amounts of
180 ** work to port to Win64, Linux, other compilers, etc.
181 **
182 ** --lch
183 */
ficlPrimitiveMulticall(ficlVm * vm)184 static void ficlPrimitiveMulticall(ficlVm *vm)
185 {
186 int flags;
187 int functionAddress;
188 int argumentCount;
189 int *thisPointer;
190 int integerReturnValue;
191 #if FICL_WANT_FLOAT
192 float floatReturnValue;
193 #endif /* FICL_WANT_FLOAT */
194 int cstringArguments;
195 int floatArguments;
196 int i;
197 char **fixups;
198 int fixupCount;
199 int fixupIndex;
200 int *argumentPointer;
201 int finalArgumentCount;
202 int argumentDirection;
203 int *adjustedArgumentPointer;
204 int originalESP;
205 int vtable;
206
207 flags = ficlStackPopInteger(vm->dataStack);
208
209 functionAddress = ficlStackPopInteger(vm->dataStack);
210 if (FICL_MULTICALL_GET_CALLTYPE(flags) == FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD)
211 functionAddress *= 4;
212
213 cstringArguments = ficlStackPopInteger(vm->dataStack);
214 floatArguments = ficlStackPopInteger(vm->dataStack);
215 #if !FICL_WANT_FLOAT
216 FICL_VM_ASSERT(vm, !floatArguments);
217 FICL_VM_ASSERT(vm, FICL_MULTICALL_GET_RETURNTYPE(flags) != FICL_MULTICALL_RETURNTYPE_FLOAT);
218 #endif /* !FICL_WANT_FLOAT */
219 argumentCount = ficlStackPopInteger(vm->dataStack);
220
221 fixupCount = 0;
222 if (cstringArguments)
223 {
224 for (i = 0; i < argumentCount; i++)
225 if (cstringArguments & (1 << i))
226 fixupCount++;
227 fixups = (char **)malloc(fixupCount * sizeof(char *));
228 }
229 else
230 {
231 fixups = NULL;
232 }
233
234
235 /* argumentCount does *not* include the *this* pointer! */
236 if (FICL_MULTICALL_GET_CALLTYPE(flags) != FICL_MULTICALL_CALLTYPE_FUNCTION)
237 {
238 if (flags & FICL_MULTICALL_EXPLICIT_VTABLE)
239 vtable = ficlStackPopInteger(vm->dataStack);
240
241 __asm push ecx
242 thisPointer = (int *)ficlStackPopPointer(vm->dataStack);
243
244 if ((flags & FICL_MULTICALL_EXPLICIT_VTABLE) == 0)
245 vtable = *thisPointer;
246 }
247
248
249 __asm mov originalESP, esp
250
251 fixupIndex = 0;
252 finalArgumentCount = argumentCount - fixupCount;
253 __asm mov argumentPointer, esp
254 adjustedArgumentPointer = argumentPointer - finalArgumentCount;
255 __asm mov esp, adjustedArgumentPointer
256 if (flags & FICL_MULTICALL_REVERSE_ARGUMENTS)
257 {
258 argumentDirection = -1;
259 argumentPointer--;
260 }
261 else
262 {
263 argumentPointer = adjustedArgumentPointer;
264 argumentDirection = 1;
265 }
266
267 for (i = 0; i < argumentCount; i++)
268 {
269 int argument;
270
271 /* a single argument can't be both a float and a cstring! */
272 FICL_VM_ASSERT(vm, !((floatArguments & 1) && (cstringArguments & 1)));
273
274 #if FICL_WANT_FLOAT
275 if (floatArguments & 1)
276 argument = ficlStackPopInteger(vm->floatStack);
277 else
278 #endif /* FICL_WANT_FLOAT */
279 argument = ficlStackPopInteger(vm->dataStack);
280
281 if (cstringArguments & 1)
282 {
283 int length;
284 char *address;
285 char *buffer;
286 address = ficlStackPopPointer(vm->dataStack);
287 length = argument;
288 buffer = malloc(length + 1);
289 memcpy(buffer, address, length);
290 buffer[length] = 0;
291 fixups[fixupIndex++] = buffer;
292 argument = (int)buffer;
293 argumentCount--;
294 floatArguments >>= 1;
295 cstringArguments >>= 1;
296 }
297
298 *argumentPointer = argument;
299 argumentPointer += argumentDirection;
300
301 floatArguments >>= 1;
302 cstringArguments >>= 1;
303 }
304
305
306 /*
307 ** note! leave the "mov ecx, thisPointer" code where it is.
308 ** yes, it's duplicated in two spots.
309 ** however, MSVC likes to use ecx as a scratch variable,
310 ** so we want to set it as close as possible before the call.
311 */
312 if (FICL_MULTICALL_GET_CALLTYPE(flags) == FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD)
313 {
314 __asm
315 {
316 /* push thisPointer */
317 mov ecx, thisPointer
318 /* put vtable into eax. */
319 mov eax, vtable
320 /* pull out the address of the function we want... */
321 add eax, functionAddress
322 /* and call it. */
323 call [eax]
324 }
325 }
326 else
327 {
328 FICL_VM_ASSERT(vm, functionAddress != 0);
329 if (FICL_MULTICALL_GET_CALLTYPE(flags))
330 {
331 __asm mov ecx, thisPointer
332 }
333 __asm call functionAddress
334 }
335
336 /* save off the return value, if there is one */
337 __asm mov integerReturnValue, eax
338 #if FICL_WANT_FLOAT
339 __asm fst floatReturnValue
340 #endif /* FICL_WANT_FLOAT */
341
342 __asm mov esp, originalESP
343
344 if (FICL_MULTICALL_GET_CALLTYPE(flags))
345 {
346 __asm pop ecx
347 }
348
349 if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_INTEGER)
350 ficlStackPushInteger(vm->dataStack, integerReturnValue);
351 else if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_CSTRING)
352 {
353 char *str = (char *)(void *)integerReturnValue;
354 ficlStackPushInteger(vm->dataStack, integerReturnValue);
355 ficlStackPushInteger(vm->dataStack, strlen(str));
356 }
357 #if FICL_WANT_FLOAT
358 else if (FICL_MULTICALL_GET_RETURNTYPE(flags) == FICL_MULTICALL_RETURNTYPE_FLOAT)
359 ficlStackPushFloat(vm->floatStack, floatReturnValue);
360 #endif /* FICL_WANT_FLOAT */
361
362 if (fixups != NULL)
363 {
364 for (i = 0; i < fixupCount; i++)
365 if (fixups[i] != NULL)
366 free(fixups[i]);
367 free(fixups);
368 }
369
370 return;
371 }
372
373
374
375
376 /**************************************************************************
377 f i c l C o m p i l e P l a t f o r m
378 ** Build Win32 platform extensions into the system dictionary
379 **************************************************************************/
ficlSystemCompilePlatform(ficlSystem * system)380 void ficlSystemCompilePlatform(ficlSystem *system)
381 {
382 HMODULE hModule;
383 ficlDictionary *dictionary = system->dictionary;
384 FICL_SYSTEM_ASSERT(system, dictionary);
385
386 /*
387 ** one native function call to rule them all, one native function call to find them,
388 ** one native function call to bring them all and in the darkness bind them.
389 ** --lch (with apologies to j.r.r.t.)
390 */
391 ficlDictionarySetPrimitive(dictionary, "multicall", ficlPrimitiveMulticall, FICL_WORD_DEFAULT);
392 ficlDictionarySetConstant(dictionary, "multicall-calltype-function", FICL_MULTICALL_CALLTYPE_FUNCTION);
393 ficlDictionarySetConstant(dictionary, "multicall-calltype-method", FICL_MULTICALL_CALLTYPE_METHOD);
394 ficlDictionarySetConstant(dictionary, "multicall-calltype-virtual-method", FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD);
395 ficlDictionarySetConstant(dictionary, "multicall-returntype-void", FICL_MULTICALL_RETURNTYPE_VOID);
396 ficlDictionarySetConstant(dictionary, "multicall-returntype-integer", FICL_MULTICALL_RETURNTYPE_INTEGER);
397 ficlDictionarySetConstant(dictionary, "multicall-returntype-cstring", FICL_MULTICALL_RETURNTYPE_CSTRING);
398 ficlDictionarySetConstant(dictionary, "multicall-returntype-float", FICL_MULTICALL_RETURNTYPE_FLOAT);
399 ficlDictionarySetConstant(dictionary, "multicall-reverse-arguments", FICL_MULTICALL_REVERSE_ARGUMENTS);
400 ficlDictionarySetConstant(dictionary, "multicall-explit-vtable", FICL_MULTICALL_EXPLICIT_VTABLE);
401
402 /*
403 ** Every other Win32-specific word is implemented in Ficl, with multicall or whatnot.
404 ** (Give me a lever, and a place to stand, and I will move the Earth.)
405 ** See softcore/win32.fr for details. --lch
406 */
407 hModule = LoadLibrary("kernel32.dll");
408 ficlDictionarySetConstantPointer(dictionary, "kernel32.dll", hModule);
409 ficlDictionarySetConstantPointer(dictionary, "(get-proc-address)", GetProcAddress(hModule, "GetProcAddress"));
410 FreeLibrary(hModule);
411
412 return;
413 }
414