diff options
Diffstat (limited to 'win32.c')
| -rw-r--r-- | win32.c | 406 |
1 files changed, 0 insertions, 406 deletions
diff --git a/win32.c b/win32.c deleted file mode 100644 index 7b9c44b38db9..000000000000 --- a/win32.c +++ /dev/null @@ -1,406 +0,0 @@ -/* - * 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 - - - - |