diff options
Diffstat (limited to 'win32.c')
| -rw-r--r-- | win32.c | 406 |
1 files changed, 406 insertions, 0 deletions
diff --git a/win32.c b/win32.c new file mode 100644 index 000000000000..7b9c44b38db9 --- /dev/null +++ b/win32.c @@ -0,0 +1,406 @@ +/* + * win32.c + * submitted to Ficl by Larry Hastings, larry@hastings.org + * Additional Win32 words by Guy Carver + * + * adds calling arbitrary DLL function calls from inside Ficl. + * + * note that Microsoft's own header files won't compile without + * "language extensions" (anonymous structs/unions) turned on. + * and even with that, it still gives a warning in rpcasync.h + * for something that compiles clean in C++. I turned it off. + * + */ +#pragma warning(disable : 4115) +#include <stdio.h> +#include <windows.h> +#include <string.h> +#include <direct.h> + +#include "ficl.h" + +static void loadLibrary(FICL_VM *pVM) /* ( address length -- hmodule ) */ +{ + int length = stackPopINT(pVM->pStack); + void *address = (void *)stackPopPtr(pVM->pStack); + + char *buf = (char *)_alloca(length + 1); + memcpy(buf, address, length); + buf[length] = 0; + + stackPushINT(pVM->pStack, (int)LoadLibrary(buf)); +} + +static void getProcAddress(FICL_VM *pVM) /* ( address length hmodule -- ) */ +{ + HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack); + int length = stackPopINT(pVM->pStack); + void *address = (void *)stackPopPtr(pVM->pStack); + + char *buf = (char *)_alloca(length + 1); + memcpy(buf, address, length); + buf[length] = 0; + + stackPushINT(pVM->pStack, (int)GetProcAddress(hModule, buf)); +} + + +static void freeLibrary(FICL_VM *pVM) /* ( hmodule -- ) */ +{ + HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack); + FreeLibrary(hModule); +} + + +static void uAddrToCString(FICL_VM *pVM) /* ( address length -- c-string ) */ +{ + int length = stackPopINT(pVM->pStack); + void *address = (void *)stackPopPtr(pVM->pStack); + + char *buf = (char *)malloc(length + 1); + memcpy(buf, address, length); + buf[length] = 0; + stackPushPtr(pVM->pStack, buf); + return; +} + + +static void callNativeFunction(FICL_VM *pVM) /* ( ... argcount fnaddress popstack -- returnvalue ) */ +{ + int popstack = stackPopINT(pVM->pStack); + int fnaddress = stackPopINT(pVM->pStack); + int argcount = stackPopINT(pVM->pStack); + int returnvalue; + + int i; + for (i = 0; i < argcount; i++) + { + int nextarg = stackPopINT(pVM->pStack); + __asm + { + mov eax, nextarg + push eax + } + } + + + __asm + { + call fnaddress + mov returnvalue, eax + } + + /* + * if popstack is nonzero, + * the arguments are popped off the stack after calling + */ + if (popstack) + { + argcount *= 4; + __asm add esp, argcount + } + stackPushINT(pVM->pStack, returnvalue); + return; +} + + +/************************************************************************** + v c a l l +** Call a class method. (Contributed by Guy Carver) +** FORTH: (params inst paramcnt vtableindex -- res ) +** INFO: paramcnt has msb set if return value is desired. +**************************************************************************/ +static void VCall(FICL_VM *pVM) +{ + int ind,p,paramCnt; + void *instance; + int I; + +#if FICL_ROBUST > 1 + vmCheckStack(pVM,3,1); +#endif + + ind = POPINT() * 4; + paramCnt = POPINT(); + instance = POPPTR(); //Get instance of class. + + __asm push ecx //Save ecx. + __asm push esp //Save stack. + + I = paramCnt & 0xFF; //Strip off any flags. + +#if FICL_ROBUST > 1 + vmCheckStack(pVM,I,0); +#endif + + while(I--) //Loop for parameter count. + { + p = POPINT(); + __asm + { + mov eax,p + push eax //Push on stack. + } + } + __asm + { + mov ecx,instance //Set ecx to instance. + mov eax,[ecx] //Get method pointer. + add eax,ind + call [eax] //Call method. + mov p,eax //Put result in p. + pop esp + pop ecx //Restore ecx and esp. + } + if (paramCnt & 0x80000000) //If supposed to return a result. + PUSHINT(p); //Store result. +} + + +#if 0 +//************************************************************** +//Load forth file. +//ENTER: pVM = Pointer to forth virtual machine. +//FORTH: ( -<FileName>- ) +//************************************************************** +static void ForthLoad(FICL_VM *pVM) +{ + char cp[256]; + char fileName[256]; + FILE *fp; + int result = 0; + CELL id; + int nLine = 0; + FICL_STRING *pFileName = (FICL_STRING *)fileName; + + vmGetString(pVM,pFileName, ' '); + + if (pFileName->count <= 0) + { + vmTextOut(pVM,"Type fload filename", 1); + return; + } + + fp = fopen(pFileName->text, "r"); + if (fp) + { + id = pVM->sourceID; + pVM->sourceID.p = (void *)fp; //Set input source id. + + while (fgets(cp,256,fp)) //Read line. + { + int len = strlen(cp) - 1; //Get length. + + nLine++; //Inc line count. + if (len > 0) //if length. + { + cp[len] = 0; //Make sure null terminated. + result = ficlExec(pVM,cp); //Execute line. + if ((result == VM_ERREXIT) //If exit. + || (result == VM_USEREXIT) + || (result == VM_QUIT)) + { + pVM->sourceID = id; + fclose(fp); + vmThrowErr(pVM, "Error loading file <%s> line %d", pFileName->text, nLine); + break; + } + } + } + pVM->sourceID.i = -1; + ficlExec(pVM,""); //Empty line to flush any pending refills. + pVM->sourceID = id; //Reset source ID. + fclose(fp); + if (result == VM_USEREXIT) //If user exit. + vmThrow(pVM,VM_USEREXIT); //Resend user exit code. + } + else + { + vmTextOut(pVM,"Unable to open file: ", 0); + vmTextOut(pVM, pFileName->text,1); + } +} + +//******************************************************************************** +// +//******************************************************************************** +static STRINGINFO parseFileName(FICL_VM *pVM) +{ + STRINGINFO si; + char *pSrc = vmGetInBuf(pVM); + si.cp = pSrc; /* mark start of text */ + while ((*pSrc != ' ') && (*pSrc != 0) && (*pSrc != '\n')) + { + if (*(pSrc++) == '\\') /* find next delimiter or end */ + si.cp = pSrc; + } + si.count = pSrc - si.cp; /* set length of result */ + return(si); +} + +//******************************************************************************** +//check for included file and load if not loaded. +//******************************************************************************** +static void include(FICL_VM *pVM) +{ + STRINGINFO si; + FICL_WORD *pFW; + FICL_DICT *dp = vmGetDict(pVM); + FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code; + + si = parseFileName(pVM); + + if (si.count) + { + pFW = dictLookup(dp, si); + if (!pFW) //Forget word. + { + dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT); + dictAllotCells(dp, 1); + ForthLoad(pVM); + } + } +} + +//******************************************************************************** +//check for included file and kill it if its included to reload. +//******************************************************************************** +static void reinclude(FICL_VM *pVM) +{ + STRINGINFO si; + FICL_WORD *pFW; + FICL_DICT *dp = vmGetDict(pVM); + FICL_CODE pCreateParen = ficlLookup(pVM->pSys, "(create)")->code; + + si = parseFileName(pVM); + + if (si.count) + { + pFW = dictLookup(dp, si); + if (pFW) //Forget word. + { + hashForget(dp->pCompile,pFW->name); + dp->here = PTRtoCELL (pFW->name); + } + + dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT); + dictAllotCells(dp, 1); + ForthLoad(pVM); + } +} + +#endif /* 0 */ + + +static void ficlWordGetTickCount(FICL_VM *pVM) /* ( -- ms ) */ +{ + stackPushINT(pVM->pStack, (int)GetTickCount()); +} + + +static void ficlDebugBreak(FICL_VM *pVM) /* ( -- ) */ +{ + DebugBreak(); + pVM = pVM; +} + + +static void ficlOutputDebugString(FICL_VM *pVM) /* ( c-addr u -- ) */ +{ + int length = stackPopINT(pVM->pStack); + void *address = (void *)stackPopPtr(pVM->pStack); + + char *buf = (char *)_alloca(length + 1); + memcpy(buf, address, length); + buf[length] = 0; + + OutputDebugString(buf); +} + + + +/************************************************************************** + f i c l C o m p i l e P l a t f o r m +** Build Win32 platform extensions into the system dictionary +**************************************************************************/ +void ficlCompilePlatform(FICL_SYSTEM *pSys) +{ + FICL_DICT *dp = pSys->dp; + assert (dp); + + dictAppendWord(dp, "loadlibrary", loadLibrary, FW_DEFAULT); + dictAppendWord(dp, "getprocaddress", getProcAddress, FW_DEFAULT); + dictAppendWord(dp, "freelibrary", freeLibrary, FW_DEFAULT); + dictAppendWord(dp, "uaddr->cstring", uAddrToCString, FW_DEFAULT); + dictAppendWord(dp, "callnativefunction", + callNativeFunction, + FW_DEFAULT); + dictAppendWord(dp, "vcall", VCall, FW_DEFAULT); +/* + dictAppendWord(dp, "include", include, FW_DEFAULT); + dictAppendWord(dp, "reinclude", reinclude, FW_DEFAULT); +*/ + dictAppendWord(dp, "GetTickCount", ficlWordGetTickCount, FW_DEFAULT); + + dictAppendWord(dp, "debug-break", ficlDebugBreak, FW_DEFAULT); + dictAppendWord(dp, "output-debug-string", ficlOutputDebugString, FW_DEFAULT); + + return; +} + + + + +/* +** +** Heavy, undocumented wizardry here. +** +** In Win32, like most OSes, the buffered file I/O functions in the +** C API (functions that take a FILE * like fopen()) are implemented +** on top of the raw file I/O functions (functions that take an int, +** like open()). However, in Win32, these functions in turn are +** implemented on top of the Win32 native file I/O functions (functions +** that take a HANDLE, like CreateFile()). This behavior is undocumented +** but easy to deduce by reading the CRT/SRC directory. +** +** The below mishmash of typedefs and defines were copied from +** CRT/SRC/INTERNAL.H. +** +** --lch +*/ +typedef struct { + long osfhnd; /* underlying OS file HANDLE */ + char osfile; /* attributes of file (e.g., open in text mode?) */ + char pipech; /* one char buffer for handles opened on pipes */ +#ifdef _MT + int lockinitflag; + CRITICAL_SECTION lock; +#endif /* _MT */ + } ioinfo; +extern _CRTIMP ioinfo * __pioinfo[]; + +#define IOINFO_L2E 5 +#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E) +#define _pioinfo(i) ( __pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - \ + 1)) ) +#define _osfhnd(i) ( _pioinfo(i)->osfhnd ) + + +int ftruncate(int fileno, size_t size) +{ + HANDLE hFile = (HANDLE)_osfhnd(fileno); + if (SetFilePointer(hFile, size, NULL, FILE_BEGIN) != size) + return 0; + return !SetEndOfFile(hFile); +} + +#if 0 +unsigned long ficlNtohl(unsigned long number) +{ + return ntohl(number); +} +#endif + + + + |