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.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