ref: 7d02e382d314d5bdde7978ccb7a64ea9201d03db
dir: 9ficl/system.c
/*******************************************************************
** 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.4 2010/12/02 13:56:43 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 = (ficlSystem*)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