common/ficl/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 "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 = FICL_VERSION_MAJOR;
	int minor = FICL_VERSION_MINOR;
	ficl2Integer combined;
	ficlDictionary *environment = ficlSystemGetEnvironment(system);
	FICL_2INTEGER_SET(major, minor, combined);
	ficlDictionarySet2Constant(environment, "ficl-version", combined);
	ficlDictionarySetConstant(environment, "ficl-robust",  FICL_ROBUST);
}

/*
 * 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_ENVIRONMENT_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_LZ4_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);
	}

	if (ficlSystemGlobal == system)
		ficlSystemGlobal = NULL;

	ficlFree(system);
	system = NULL;
}

/*
 * 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;
	ficlCell c;

	word = ficlDictionaryAppendPrimitive(dictionary, name,
	    ficlPrimitiveParseStepParen, FICL_WORD_DEFAULT);

	c.fn = (void (*)(void))pStep;
	ficlDictionaryAppendCell(dictionary, c);
	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);
}

/*
 * 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