diff options
Diffstat (limited to 'system.c')
| -rw-r--r-- | system.c | 466 |
1 files changed, 466 insertions, 0 deletions
diff --git a/system.c b/system.c new file mode 100644 index 000000000000..6caff931cf6f --- /dev/null +++ b/system.c @@ -0,0 +1,466 @@ +/******************************************************************* +** f i c l . c +** Forth Inspired Command Language - external interface +** Author: John Sadler (john_sadler@alum.mit.edu) +** Created: 19 July 1997 +** $Id: system.c,v 1.2 2010/09/10 10:35:54 asau Exp $ +*******************************************************************/ +/* +** This is an ANS Forth interpreter written in C. +** Ficl uses Forth syntax for its commands, but turns the Forth +** model on its head in other respects. +** Ficl provides facilities for interoperating +** with programs written in C: C functions can be exported to Ficl, +** and Ficl commands can be executed via a C calling interface. The +** interpreter is re-entrant, so it can be used in multiple instances +** in a multitasking system. Unlike Forth, Ficl's outer interpreter +** expects a text block as input, and returns to the caller after each +** text block, so the data pump is somewhere in external code in the +** style of TCL. +** +** Code is written in ANSI C for portability. +*/ +/* +** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) +** All rights reserved. +** +** Get the latest Ficl release at http://ficl.sourceforge.net +** +** I am interested in hearing from anyone who uses Ficl. If you have +** a problem, a success story, a defect, an enhancement request, or +** if you would like to contribute to the Ficl release, please +** contact me by email at the address above. +** +** L I C E N S E and D I S C L A I M E R +** +** Redistribution and use in source and binary forms, with or without +** modification, are permitted provided that the following conditions +** are met: +** 1. Redistributions of source code must retain the above copyright +** notice, this list of conditions and the following disclaimer. +** 2. Redistributions in binary form must reproduce the above copyright +** notice, this list of conditions and the following disclaimer in the +** documentation and/or other materials provided with the distribution. +** +** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +** SUCH DAMAGE. +*/ + +#include <stdlib.h> +#include <string.h> +#include "ficl.h" + + +/* +** System statics +** Each ficlSystem builds a global dictionary during its start +** sequence. This is shared by all virtual machines of that system. +** Therefore only one VM can update the dictionary +** at a time. The system imports a locking function that +** you can override in order to control update access to +** the dictionary. The function is stubbed out by default, +** but you can insert one: #define FICL_WANT_MULTITHREADED 1 +** and supply your own version of ficlDictionaryLock. +*/ + + +ficlSystem *ficlSystemGlobal = NULL; + +/************************************************************************** + f i c l S e t V e r s i o n E n v +** Create a double ficlCell environment constant for the version ID +**************************************************************************/ +static void ficlSystemSetVersion(ficlSystem *system) +{ + int major = 0; + int minor = 0; + ficl2Integer combined; + ficlDictionary *environment = ficlSystemGetEnvironment(system); + sscanf(FICL_VERSION, "%d.%d", &major, &minor); + FICL_2INTEGER_SET(major, minor, combined); + ficlDictionarySet2Constant(environment, "ficl-version", combined); + ficlDictionarySetConstant(environment, "ficl-robust", FICL_ROBUST); + return; +} + + + + + +/************************************************************************** + f i c l I n i t S y s t e m +** Binds a global dictionary to the interpreter system. +** You specify the address and size of the allocated area. +** After that, Ficl manages it. +** First step is to set up the static pointers to the area. +** Then write the "precompiled" portion of the dictionary in. +** The dictionary needs to be at least large enough to hold the +** precompiled part. Try 1K cells minimum. Use "words" to find +** out how much of the dictionary is used at any time. +**************************************************************************/ +ficlSystem *ficlSystemCreate(ficlSystemInformation *fsi) +{ + ficlInteger dictionarySize; + ficlInteger environmentSize; + ficlInteger stackSize; + ficlSystem *system; + ficlCallback callback; + ficlSystemInformation fauxInfo; + ficlDictionary *environment; + + + + if (fsi == NULL) + { + fsi = &fauxInfo; + ficlSystemInformationInitialize(fsi); + } + + callback.context = fsi->context; + callback.textOut = fsi->textOut; + callback.errorOut = fsi->errorOut; + callback.system = NULL; + callback.vm = NULL; + + FICL_ASSERT(&callback, sizeof(ficlInteger) >= sizeof(void *)); + FICL_ASSERT(&callback, sizeof(ficlUnsigned) >= sizeof(void *)); +#if (FICL_WANT_FLOAT) + FICL_ASSERT(&callback, sizeof(ficlFloat) <= sizeof(ficlInteger)); +#endif + + system = ficlMalloc(sizeof(ficlSystem)); + + FICL_ASSERT(&callback, system); + + memset(system, 0, sizeof(ficlSystem)); + + dictionarySize = fsi->dictionarySize; + if (dictionarySize <= 0) + dictionarySize = FICL_DEFAULT_DICTIONARY_SIZE; + + environmentSize = fsi->environmentSize; + if (environmentSize <= 0) + environmentSize = FICL_DEFAULT_DICTIONARY_SIZE; + + stackSize = fsi->stackSize; + if (stackSize < FICL_DEFAULT_STACK_SIZE) + stackSize = FICL_DEFAULT_STACK_SIZE; + + system->dictionary = ficlDictionaryCreateHashed(system, (unsigned)dictionarySize, FICL_HASH_SIZE); + system->dictionary->forthWordlist->name = "forth-wordlist"; + + environment = ficlDictionaryCreate(system, (unsigned)environmentSize); + system->environment = environment; + system->environment->forthWordlist->name = "environment"; + + system->callback.textOut = fsi->textOut; + system->callback.errorOut = fsi->errorOut; + system->callback.context = fsi->context; + system->callback.system = system; + system->callback.vm = NULL; + system->stackSize = stackSize; + +#if FICL_WANT_LOCALS + /* + ** The locals dictionary is only searched while compiling, + ** but this is where speed is most important. On the other + ** hand, the dictionary gets emptied after each use of locals + ** The need to balance search speed with the cost of the 'empty' + ** operation led me to select a single-threaded list... + */ + system->locals = ficlDictionaryCreate(system, (unsigned)FICL_MAX_LOCALS * FICL_CELLS_PER_WORD); +#endif /* FICL_WANT_LOCALS */ + + /* + ** Build the precompiled dictionary and load softwords. We need a temporary + ** VM to do this - ficlNewVM links one to the head of the system VM list. + ** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words. + */ + ficlSystemCompileCore(system); + ficlSystemCompilePrefix(system); + +#if FICL_WANT_FLOAT + ficlSystemCompileFloat(system); +#endif /* FICL_WANT_FLOAT */ + +#if FICL_WANT_PLATFORM + ficlSystemCompilePlatform(system); +#endif /* FICL_WANT_PLATFORM */ + + ficlSystemSetVersion(system); + + /* + ** Establish the parse order. Note that prefixes precede numbers - + ** this allows constructs like "0b101010" which might parse as a + ** hex value otherwise. + */ + ficlSystemAddPrimitiveParseStep(system, "?word", ficlVmParseWord); + ficlSystemAddPrimitiveParseStep(system, "?prefix", ficlVmParsePrefix); + ficlSystemAddPrimitiveParseStep(system, "?number", ficlVmParseNumber); +#if FICL_WANT_FLOAT + ficlSystemAddPrimitiveParseStep(system, "?float", ficlVmParseFloatNumber); +#endif + + /* + ** Now create a temporary VM to compile the softwords. Since all VMs are + ** linked into the vmList of ficlSystem, we don't have to pass the VM + ** to ficlCompileSoftCore -- it just hijacks whatever it finds in the VM list. + ** Ficl 2.05: vmCreate no longer depends on the presence of INTERPRET in the + ** dictionary, so a VM can be created before the dictionary is built. It just + ** can't do much... + */ + ficlSystemCreateVm(system); +#define ADD_COMPILE_FLAG(name) ficlDictionarySetConstant(environment, #name, name) + ADD_COMPILE_FLAG(FICL_WANT_LZ_SOFTCORE); + ADD_COMPILE_FLAG(FICL_WANT_FILE); + ADD_COMPILE_FLAG(FICL_WANT_FLOAT); + ADD_COMPILE_FLAG(FICL_WANT_DEBUGGER); + ADD_COMPILE_FLAG(FICL_WANT_EXTENDED_PREFIX); + ADD_COMPILE_FLAG(FICL_WANT_USER); + ADD_COMPILE_FLAG(FICL_WANT_LOCALS); + ADD_COMPILE_FLAG(FICL_WANT_OOP); + ADD_COMPILE_FLAG(FICL_WANT_SOFTWORDS); + ADD_COMPILE_FLAG(FICL_WANT_MULTITHREADED); + ADD_COMPILE_FLAG(FICL_WANT_OPTIMIZE); + ADD_COMPILE_FLAG(FICL_WANT_VCALL); + + ADD_COMPILE_FLAG(FICL_PLATFORM_ALIGNMENT); + + ADD_COMPILE_FLAG(FICL_ROBUST); + +#define ADD_COMPILE_STRING(name) ficlDictionarySetConstantString(environment, #name, name) + ADD_COMPILE_STRING(FICL_PLATFORM_ARCHITECTURE); + ADD_COMPILE_STRING(FICL_PLATFORM_OS); + + ficlSystemCompileSoftCore(system); + ficlSystemDestroyVm(system->vmList); + + if (ficlSystemGlobal == NULL) + ficlSystemGlobal = system; + + return system; +} + + + +/************************************************************************** + f i c l T e r m S y s t e m +** Tear the system down by deleting the dictionaries and all VMs. +** This saves you from having to keep track of all that stuff. +**************************************************************************/ +void ficlSystemDestroy(ficlSystem *system) +{ + if (system->dictionary) + ficlDictionaryDestroy(system->dictionary); + system->dictionary = NULL; + + if (system->environment) + ficlDictionaryDestroy(system->environment); + system->environment = NULL; + +#if FICL_WANT_LOCALS + if (system->locals) + ficlDictionaryDestroy(system->locals); + system->locals = NULL; +#endif + + while (system->vmList != NULL) + { + ficlVm *vm = system->vmList; + system->vmList = system->vmList->link; + ficlVmDestroy(vm); + } + + ficlFree(system); + system = NULL; + + if (ficlSystemGlobal == system) + ficlSystemGlobal = NULL; + + return; +} + + +/************************************************************************** + f i c l A d d P a r s e S t e p +** Appends a parse step function to the end of the parse list (see +** ficlParseStep notes in ficl.h for details). Returns 0 if successful, +** nonzero if there's no more room in the list. +**************************************************************************/ +int ficlSystemAddParseStep(ficlSystem *system, ficlWord *word) +{ + int i; + for (i = 0; i < FICL_MAX_PARSE_STEPS; i++) + { + if (system->parseList[i] == NULL) + { + system->parseList[i] = word; + return 0; + } + } + + return 1; +} + + +/* +** Compile a word into the dictionary that invokes the specified ficlParseStep +** function. It is up to the user (as usual in Forth) to make sure the stack +** preconditions are valid (there needs to be a counted string on top of the stack) +** before using the resulting word. +*/ +void ficlSystemAddPrimitiveParseStep(ficlSystem *system, char *name, ficlParseStep pStep) +{ + ficlDictionary *dictionary = system->dictionary; + ficlWord *word = ficlDictionaryAppendPrimitive(dictionary, name, ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT); + ficlDictionaryAppendCell(dictionary, FICL_LVALUE_TO_CELL(pStep)); + ficlSystemAddParseStep(system, word); +} +/************************************************************************** + f i c l N e w V M +** Create a new virtual machine and link it into the system list +** of VMs for later cleanup by ficlTermSystem. +**************************************************************************/ +ficlVm *ficlSystemCreateVm(ficlSystem *system) +{ + ficlVm *vm = ficlVmCreate(NULL, system->stackSize, system->stackSize); + vm->link = system->vmList; + + memcpy(&(vm->callback), &(system->callback), sizeof(system->callback)); + vm->callback.vm = vm; + vm->callback.system = system; + + system->vmList = vm; + return vm; +} + + +/************************************************************************** + f i c l F r e e V M +** Removes the VM in question from the system VM list and deletes the +** memory allocated to it. This is an optional call, since ficlTermSystem +** will do this cleanup for you. This function is handy if you're going to +** do a lot of dynamic creation of VMs. +**************************************************************************/ +void ficlSystemDestroyVm(ficlVm *vm) +{ + ficlSystem *system = vm->callback.system; + ficlVm *pList = system->vmList; + + FICL_VM_ASSERT(vm, vm != NULL); + + if (system->vmList == vm) + { + system->vmList = system->vmList->link; + } + else for (; pList != NULL; pList = pList->link) + { + if (pList->link == vm) + { + pList->link = vm->link; + break; + } + } + + if (pList) + ficlVmDestroy(vm); + return; +} + + +/************************************************************************** + f i c l L o o k u p +** Look in the system dictionary for a match to the given name. If +** found, return the address of the corresponding ficlWord. Otherwise +** return NULL. +**************************************************************************/ +ficlWord *ficlSystemLookup(ficlSystem *system, char *name) +{ + ficlString s; + FICL_STRING_SET_FROM_CSTRING(s, name); + return ficlDictionaryLookup(system->dictionary, s); +} + + +/************************************************************************** + f i c l G e t D i c t +** Returns the address of the system dictionary +**************************************************************************/ +ficlDictionary *ficlSystemGetDictionary(ficlSystem *system) +{ + return system->dictionary; +} + + +/************************************************************************** + f i c l G e t E n v +** Returns the address of the system environment space +**************************************************************************/ +ficlDictionary *ficlSystemGetEnvironment(ficlSystem *system) +{ + return system->environment; +} + + +/************************************************************************** + f i c l G e t L o c +** Returns the address of the system locals dictionary. This dictionary is +** only used during compilation, and is shared by all VMs. +**************************************************************************/ +#if FICL_WANT_LOCALS +ficlDictionary *ficlSystemGetLocals(ficlSystem *system) +{ + return system->locals; +} +#endif + + + +/************************************************************************** + f i c l L o o k u p L o c +** Same as dictLookup, but looks in system locals dictionary first... +** Assumes locals dictionary has only one wordlist... +**************************************************************************/ +#if FICL_WANT_LOCALS +ficlWord *ficlSystemLookupLocal(ficlSystem *system, ficlString name) +{ + ficlWord *word = NULL; + ficlDictionary *dictionary = system->dictionary; + ficlHash *hash = ficlSystemGetLocals(system)->forthWordlist; + int i; + ficlUnsigned16 hashCode = ficlHashCode(name); + + FICL_SYSTEM_ASSERT(system, hash); + FICL_SYSTEM_ASSERT(system, dictionary); + + ficlDictionaryLock(dictionary, FICL_TRUE); + /* + ** check the locals dictionary first... + */ + word = ficlHashLookup(hash, name, hashCode); + + /* + ** If no joy, (!word) ------------------------------v + ** iterate over the search list in the main dictionary + */ + for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i) + { + hash = dictionary->wordlists[i]; + word = ficlHashLookup(hash, name, hashCode); + } + + ficlDictionaryLock(dictionary, FICL_FALSE); + return word; +} +#endif + + |