static void ficlPrimitiveRenameFile(ficlVm *vm) /* ( c-addr1 u1 c-addr2 u2 -- ior ) */ { int length; void *address; char *from; char *to; length = ficlStackPopInteger(vm->dataStack); address = (void *)ficlStackPopPointer(vm->dataStack); to = (char *)malloc(length + 1); memcpy(to, address, length); to[length] = 0; length = ficlStackPopInteger(vm->dataStack); address = (void *)ficlStackPopPointer(vm->dataStack); from = (char *)malloc(length + 1); memcpy(from, address, length); from[length] = 0; pushIor(vm, !rename(from, to)); free(from); free(to); }
static void ficlPrimitiveWriteFile(ficlVm *vm) /* ( c-addr u1 fileid -- ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); clearerr(ff->f); fwrite(address, 1, length, ff->f); pushIor(vm, ferror(ff->f) == 0); }
/* * setParentWid * Ficl * setparentwid ( parent-wid wid -- ) * Set WID's link field to the parent-wid. search-wordlist will * iterate through all the links when finding words in the child wid. */ static void ficlPrimitiveSetParentWid(ficlVm *vm) { ficlHash *parent, *child; FICL_STACK_CHECK(vm->dataStack, 2, 0); child = (ficlHash *)ficlStackPopPointer(vm->dataStack); parent = (ficlHash *)ficlStackPopPointer(vm->dataStack); child->link = parent; }
static void ficlPrimitiveReadFile(ficlVm *vm) /* ( c-addr u1 fileid -- u2 ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); int result; clearerr(ff->f); result = fread(address, 1, length, ff->f); ficlStackPushInteger(vm->dataStack, result); pushIor(vm, ferror(ff->f) == 0); }
static void ficlIcatPFileWrite(ficlVm *vm) { uint32_t len; char *buffer, md5[36]; uint32_t filename_len; char *filename; FICL_STACK_CHECK(vm->dataStack,2,0); filename_len = ficlStackPopUnsigned(vm->dataStack); filename = (char *) ficlStackPopPointer(vm->dataStack); len = ficlStackPopUnsigned(vm->dataStack); buffer = (char *) ficlStackPopPointer(vm->dataStack); calcMd5(buffer,len,md5); writeIsfFile(filename,md5,len,buffer,1); }
static void ficlPrimitiveFileSize(ficlVm *vm) /* ( fileid -- ud ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); long ud = ficlFileSize(ff); ficlStackPushInteger(vm->dataStack, ud); pushIor(vm, ud != -1); }
void ficl_taskSpawn(ficlVm *vm) { int tNameLen; char *tName; int priority; int flags; int stackSize; unsigned command; char *taskName; FICL_STACK_CHECK(vm->dataStack,6,0); tNameLen = ficlStackPopInteger(vm->dataStack); tName = ficlStackPopPointer(vm->dataStack); priority = ficlStackPopInteger(vm->dataStack); flags = ficlStackPopInteger(vm->dataStack); stackSize = ficlStackPopInteger(vm->dataStack); command = ficlStackPopUnsigned(vm->dataStack); if (simon_system == NULL) simon_boot(NULL); taskName = malloc(strlen(tName)+1); strcpy(taskName,tName); taskSpawn(taskName,priority,flags,stackSize, spawn_helper,command,(int)taskName,0,0,0,0,0,0,0,0); }
static void ficlPrimitiveResizeFile(ficlVm *vm) /* ( ud fileid -- ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); size_t ud = (size_t)ficlStackPopInteger(vm->dataStack); pushIor(vm, ficlFileTruncate(ff, ud) == 0); }
static void ficlPrimitiveRepositionFile(ficlVm *vm) /* ( ud fileid -- ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); size_t ud = (size_t)ficlStackPopInteger(vm->dataStack); pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0); }
/* * s e t - o r d e r * SEARCH ( widn ... wid1 n -- ) * Set the search order to the word lists identified by widn ... wid1. * Subsequently, word list wid1 will be searched first, and word list * widn searched last. If n is zero, empty the search order. If n is minus * one, set the search order to the implementation-defined minimum * search order. The minimum search order shall include the words * FORTH-WORDLIST and SET-ORDER. A system shall allow n to * be at least eight. */ static void ficlPrimitiveSetOrder(ficlVm *vm) { int i; int wordlistCount = ficlStackPopInteger(vm->dataStack); ficlDictionary *dictionary = ficlVmGetDictionary(vm); if (wordlistCount > FICL_MAX_WORDLISTS) { ficlVmThrowError(vm, "set-order error: list would be too large"); } ficlDictionaryLock(dictionary, FICL_TRUE); if (wordlistCount >= 0) { dictionary->wordlistCount = wordlistCount; for (i = wordlistCount-1; i >= 0; --i) { dictionary->wordlists[i] = ficlStackPopPointer(vm->dataStack); } } else { ficlDictionaryResetSearchOrder(dictionary); } ficlDictionaryLock(dictionary, FICL_FALSE); }
/* * s e t - c u r r e n t * SEARCH ( wid -- ) * Set the compilation word list to the word list identified by wid. */ static void ficlPrimitiveSetCurrent(ficlVm *vm) { ficlHash *hash = ficlStackPopPointer(vm->dataStack); ficlDictionary *dictionary = ficlVmGetDictionary(vm); ficlDictionaryLock(dictionary, FICL_TRUE); dictionary->compilationWordlist = hash; ficlDictionaryLock(dictionary, FICL_FALSE); }
void ficl_diagPrint(ficlVm *vm) { int len; char *buffer; FICL_STACK_CHECK(vm->dataStack,2,0); len = ficlStackPopUnsigned(vm->dataStack); buffer = (char *) ficlStackPopPointer(vm->dataStack); diagPrint(" ",buffer); }
static void ficlPrimitiveDeleteFile(ficlVm *vm) /* ( c-addr u -- ior ) */ { int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; pushIor(vm, !unlink(filename)); free(filename); }
/* * > S E A R C H * Ficl ( wid -- ) * Push wid onto the search order. Error if the search order is full. */ static void ficlPrimitiveSearchPush(ficlVm *vm) { ficlDictionary *dictionary = ficlVmGetDictionary(vm); ficlDictionaryLock(dictionary, FICL_TRUE); if (dictionary->wordlistCount > FICL_MAX_WORDLISTS) { ficlVmThrowError(vm, ">search error: search order overflow"); } dictionary->wordlists[dictionary->wordlistCount++] = ficlStackPopPointer(vm->dataStack); ficlDictionaryLock(dictionary, FICL_FALSE); }
static void ficlPrimitiveReadLine(ficlVm *vm) /* ( c-addr u1 fileid -- u2 flag ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); char *address = (char *)ficlStackPopPointer(vm->dataStack); int error; int flag; if (feof(ff->f)) { ficlStackPushInteger(vm->dataStack, -1); ficlStackPushInteger(vm->dataStack, 0); ficlStackPushInteger(vm->dataStack, 0); return; } clearerr(ff->f); *address = 0; fgets(address, length, ff->f); error = ferror(ff->f); if (error != 0) { ficlStackPushInteger(vm->dataStack, -1); ficlStackPushInteger(vm->dataStack, 0); ficlStackPushInteger(vm->dataStack, error); return; } length = strlen(address); flag = (length > 0); if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n'))) length--; ficlStackPushInteger(vm->dataStack, length); ficlStackPushInteger(vm->dataStack, flag); ficlStackPushInteger(vm->dataStack, 0); /* ior */ }
static void ficlIcatFileWrite(ficlVm *vm) { uint32_t len; char *buffer, md5[36]; char filename[FICL_COUNTED_STRING_MAX]; ficlCountedString *counted = (ficlCountedString *)filename; FICL_STACK_CHECK(vm->dataStack,2,0); len = ficlStackPopUnsigned(vm->dataStack); buffer = (char *) ficlStackPopPointer(vm->dataStack); calcMd5(buffer,len,md5); ficlVmGetString(vm, counted, '\n'); writeIsfFile(FICL_COUNTED_STRING_GET_POINTER(*counted),md5,len,buffer,1); }
static void ficlFileOpen(ficlVm *vm, char *writeMode) /* ( c-addr u fam -- fileid ior ) */ { int fam = ficlStackPopInteger(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char mode[4]; FILE *f; char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; *mode = 0; switch (FICL_FAM_OPEN_MODE(fam)) { case 0: ficlStackPushPointer(vm->dataStack, NULL); ficlStackPushInteger(vm->dataStack, EINVAL); goto EXIT; case FICL_FAM_READ: strcat(mode, "r"); break; case FICL_FAM_WRITE: strcat(mode, writeMode); break; case FICL_FAM_READ | FICL_FAM_WRITE: strcat(mode, writeMode); strcat(mode, "+"); break; } strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t"); f = fopen(filename, mode); if (f == NULL) ficlStackPushPointer(vm->dataStack, NULL); else { ficlFile *ff = (ficlFile *)malloc(sizeof(ficlFile)); strcpy(ff->filename, filename); ff->f = f; ficlStackPushPointer(vm->dataStack, ff); fseek(f, 0, SEEK_SET); } pushIor(vm, f != NULL); EXIT: free(filename); }
/* * s e a r c h - w o r d l i s t * SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) * Find the definition identified by the string c-addr u in the word list * identified by wid. If the definition is not found, return zero. If the * definition is found, return its execution token xt and one (1) if the * definition is immediate, minus-one (-1) otherwise. */ static void ficlPrimitiveSearchWordlist(ficlVm *vm) { ficlString name; ficlUnsigned16 hashCode; ficlWord *word; ficlHash *hash = ficlStackPopPointer(vm->dataStack); name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack); name.text = ficlStackPopPointer(vm->dataStack); hashCode = ficlHashCode(name); ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE); word = ficlHashLookup(hash, name, hashCode); ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE); if (word) { ficlStackPushPointer(vm->dataStack, word); ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1)); } else { ficlStackPushUnsigned(vm->dataStack, 0); } }
static void ficlPrimitiveFileStatus(ficlVm *vm) /* ( c-addr u -- x ior ) */ { int status; int ior; int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; ior = ficlFileStatus(filename, &status); free(filename); ficlStackPushInteger(vm->dataStack, status); ficlStackPushInteger(vm->dataStack, ior); }
static void ficlPrimitiveIncludeFile(ficlVm *vm) /* ( i*x fileid -- j*x ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); ficlCell id = vm->sourceId; int except = FICL_VM_STATUS_OUT_OF_TEXT; long currentPosition, totalSize; long size; ficlString s; vm->sourceId.p = (void *)ff; currentPosition = ftell(ff->f); totalSize = ficlFileSize(ff); size = totalSize - currentPosition; if ((totalSize != -1) && (currentPosition != -1) && (size > 0)) { char *buffer = (char *)malloc(size); long got = fread(buffer, 1, size, ff->f); if (got == size) { FICL_STRING_SET_POINTER(s, buffer); FICL_STRING_SET_LENGTH(s, size); except = ficlVmExecuteString(vm, s); } } if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT)) ficlVmThrow(vm, except); /* ** Pass an empty line with SOURCE-ID == -1 to flush ** any pending REFILLs (as required by FILE wordset) */ vm->sourceId.i = -1; FICL_STRING_SET_FROM_CSTRING(s, ""); ficlVmExecuteString(vm, s); vm->sourceId = id; ficlFileClose(ff); }
static void ficlPrimitiveFlushFile(ficlVm *vm) /* ( fileid -- ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); pushIor(vm, fflush(ff->f) == 0); }
/* ** m u l t i c a l l ** ** The be-all, end-all, swiss-army-chainsaw of native function call methods in Ficl. ** ** Usage: ** ( x*argumentCount [this] [vtable] argumentCount floatArgumentBitfield cstringArgumentBitfield functionAddress flags -- returnValue | ) ** Note that any/all of the arguments (x*argumentCount) and the return value can use the ** float stack instead of the data stack. ** ** To call a simple native function: ** call with flags = MULTICALL_CALLTYPE_FUNCTION ** To call a method on an object: ** pass in the "this" pointer just below argumentCount, ** call with flags = MULTICALL_CALLTYPE_METHOD ** *do not* include the "this" pointer for the purposes of argumentCount ** To call a virtual method on an object: ** pass in the "this" pointer just below argumentCount, ** call with flags = MULTICALL_CALLTYPE_VIRTUAL_METHOD ** *do not* include the "this" pointer for the purposes of argumentCount ** the function address must be the offset into the vtable for that function ** It doesn't matter whether the function you're calling is "stdcall" (caller pops ** the stack) or "fastcall" (callee pops the stack); for robustness, multicall ** always restores the original stack pointer anyway. ** ** ** To handle floating-point arguments: ** To thunk an argument from the float stack instead of the data stack, set the corresponding bit ** in the "floatArgumentBitfield" argument. Argument zero is bit 0 (1), argument one is bit 1 (2), ** argument 2 is is bit 2 (4), argument 3 is bit 3 (8), etc. For instance, to call this function: ** float greasyFingers(int a, float b, int c, float d) ** you would call ** 4 \ argumentCount ** 2 8 or \ floatArgumentBitfield, thunk argument 2 (2) and 4 (8) ** 0 \ cstringArgumentBitfield, don't thunk any arguments ** (addressOfGreasyFingers) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-FLOAT or multicall ** ** To handle automatic conversion of addr-u arguments to C-style strings: ** This is much like handling float arguments. The bit set in cstringArgumentBitfield specifies ** the *length* argument (the higher of the two arguments) for each addr-u you want converted. ** You must count *both* arguments for the purposes of the argumentCount parameter. ** For instance, to call the Win32 function MessageBoxA: ** ** 0 "Howdy there!" "Title" 0 ** 6 \ argument count is 6! flags text-addr text-u title-addr title-u hwnd ** 0 \ floatArgumentBitfield, don't thunk any float arguments ** 2 8 or \ cstringArgumentBitfield, thunk for title-u (argument 2, 2) and text-u (argument 4, 8) ** (addressOfMessageBoxA) MULTICALL-CALLTYPE-FUNCTION MULTICALL-RETURNTYPE-INTEGER or multicall ** The strings are copied to temporary storage and appended with a zero. These strings are freed ** before multicall returns. If you need to call functions that write to these string buffers, ** you'll need to handle thunking those arguments yourself. ** ** (If you want to call a function with more than 32 parameters, and do thunking, you need to hit somebody ** in the head with a rock. Note: this could be you!) ** ** Note that, big surprise, this function is really really really dependent ** on predefined behavior of Win32 and MSVC. It would be non-zero amounts of ** work to port to Win64, Linux, other compilers, etc. ** ** --lch */ static void ficlPrimitiveMulticall(ficlVm *vm) { int flags; int functionAddress; int argumentCount; int *thisPointer; int integerReturnValue; #if FICL_WANT_FLOAT float floatReturnValue; #endif /* FICL_WANT_FLOAT */ int cstringArguments; int floatArguments; int i; char **fixups; int fixupCount; int fixupIndex; int *argumentPointer; int finalArgumentCount; int argumentDirection; int *adjustedArgumentPointer; int originalESP; int vtable; flags = ficlStackPopInteger(vm->dataStack); functionAddress = ficlStackPopInteger(vm->dataStack); if (FICL_MULTICALL_GET_CALLTYPE(flags) == FICL_MULTICALL_CALLTYPE_VIRTUAL_METHOD) functionAddress *= 4; cstringArguments = ficlStackPopInteger(vm->dataStack); floatArguments = ficlStackPopInteger(vm->dataStack); #if !FICL_WANT_FLOAT FICL_VM_ASSERT(vm, !floatArguments); FICL_VM_ASSERT(vm, FICL_MULTICALL_GET_RETURNTYPE(flags) != FICL_MULTICALL_RETURNTYPE_FLOAT); #endif /* !FICL_WANT_FLOAT */ argumentCount = ficlStackPopInteger(vm->dataStack); fixupCount = 0; if (cstringArguments) { for (i = 0; i < argumentCount; i++) if (cstringArguments & (1 << i)) fixupCount++; fixups = (char **)malloc(fixupCount * sizeof(char *)); } else { fixups = NULL; } /* argumentCount does *not* include the *this* pointer! */ if (FICL_MULTICALL_GET_CALLTYPE(flags) != FICL_MULTICALL_CALLTYPE_FUNCTION) { if (flags & FICL_MULTICALL_EXPLICIT_VTABLE) vtable = ficlStackPopInteger(vm->dataStack); __asm push ecx thisPointer = (int *)ficlStackPopPointer(vm->dataStack); if ((flags & FICL_MULTICALL_EXPLICIT_VTABLE) == 0) vtable = *thisPointer; } __asm mov originalESP, esp fixupIndex = 0; finalArgumentCount = argumentCount - fixupCount; __asm mov argumentPointer, esp adjustedArgumentPointer = argumentPointer - finalArgumentCount; __asm mov esp, adjustedArgumentPointer if (flags & FICL_MULTICALL_REVERSE_ARGUMENTS) { argumentDirection = -1; argumentPointer--; } else { argumentPointer = adjustedArgumentPointer; argumentDirection = 1; } for (i = 0; i < argumentCount; i++) { int argument; /* a single argument can't be both a float and a cstring! */ FICL_VM_ASSERT(vm, !((floatArguments & 1) && (cstringArguments & 1))); #if FICL_WANT_FLOAT if (floatArguments & 1) argument = ficlStackPopInteger(vm->floatStack); else #endif /* FICL_WANT_FLOAT */ argument = ficlStackPopInteger(vm->dataStack); if (cstringArguments & 1) { int length; char *address; char *buffer; address = ficlStackPopPointer(vm->dataStack); length = argument; buffer = malloc(length + 1); memcpy(buffer, address, length); buffer[length] = 0; fixups[fixupIndex++] = buffer; argument = (int)buffer; argumentCount--; floatArguments >>= 1; cstringArguments >>= 1; } *argumentPointer = argument; argumentPointer += argumentDirection; floatArguments >>= 1; cstringArguments >>= 1; }
/* * Shim for taking commands from BF and passing them out to 'standard' * argv/argc command functions. */ static void bf_command(ficlVm *vm) { char *name, *line, *tail, *cp; size_t len; struct bootblk_command **cmdp; bootblk_cmd_t *cmd; int nstrings, i; int argc, result; char **argv; /* Get the name of the current word */ name = vm->runningWord->name; /* Find our command structure */ cmd = NULL; SET_FOREACH(cmdp, Xcommand_set) { if (((*cmdp)->c_name != NULL) && strcmp(name, (*cmdp)->c_name) == 0) cmd = (*cmdp)->c_fn; } if (cmd == NULL) panic("callout for unknown command '%s'", name); /* Check whether we have been compiled or are being interpreted */ if (ficlStackPopInteger(ficlVmGetDataStack(vm))) { /* * Get parameters from stack, in the format: * an un ... a2 u2 a1 u1 n -- * Where n is the number of strings, a/u are pairs of * address/size for strings, and they will be concatenated * in LIFO order. */ nstrings = ficlStackPopInteger(ficlVmGetDataStack(vm)); for (i = 0, len = 0; i < nstrings; i++) { ficlStack *stack = ficlVmGetDataStack(vm); len += ficlStackFetch(stack, i * 2).i + 1; } line = malloc(strlen(name) + len + 1); strcpy(line, name); if (nstrings) for (i = 0; i < nstrings; i++) { ficlStack *stack = ficlVmGetDataStack(vm); len = ficlStackPopInteger(stack); cp = ficlStackPopPointer(stack); strcat(line, " "); strncat(line, cp, len); } } else { /* Get remainder of invocation */ tail = ficlVmGetInBuf(vm); len = 0; cp = tail; for (; cp != vm->tib.end && *cp != 0 && *cp != '\n'; cp++) len++; line = malloc(strlen(name) + len + 2); strcpy(line, name); if (len > 0) { strcat(line, " "); strncat(line, tail, len); ficlVmUpdateTib(vm, tail + len); } } DPRINTF("cmd '%s'", line); command_errmsg = command_errbuf; command_errbuf[0] = 0; if (!parse(&argc, &argv, line)) { result = (cmd)(argc, argv); free(argv); } else { result = BF_PARSE; } switch (result) { case CMD_CRIT: printf("%s\n", command_errmsg); command_errmsg = NULL; break; case CMD_FATAL: panic("%s", command_errmsg); } free(line); /* * If there was error during nested ficlExec(), we may no longer have * valid environment to return. Throw all exceptions from here. */ if (result != CMD_OK) ficlVmThrow(vm, result); /* This is going to be thrown!!! */ ficlStackPushInteger(ficlVmGetDataStack(vm), result); }
FICL_PLATFORM_EXTERN void *stackPopPtr (ficlStack *stack) { return ficlStackPopPointer(stack); }
static void ficlPrimitiveCloseFile(ficlVm *vm) /* ( fileid -- ior ) */ { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); pushIor(vm, ficlFileClose(ff)); }