ref: 67757267d0b9c6b15a0f9a87abab74ab152d9b09
dir: /dictionary.c/
/*******************************************************************
** d i c t . c
** Forth Inspired Command Language - dictionary methods
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 19 July 1997
** $Id: dictionary.c,v 1.6 2010/12/02 22:14:12 asau Exp $
*******************************************************************/
/*
** This file implements the dictionary -- Ficl's model of
** memory management. All Ficl words are stored in the
** dictionary. A word is a named chunk of data with its
** associated code. Ficl treats all words the same, even
** precompiled ones, so your words become first-class
** extensions of the language. You can even define new
** control structures.
**
** 29 jun 1998 (sadler) added variable sized hash table support
*/
/*
** 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 <ctype.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "ficl.h"
#define FICL_SAFE_CALLBACK_FROM_SYSTEM(system) (((system) != NULL) ? &((system)->callback) : NULL)
#define FICL_SAFE_SYSTEM_FROM_DICTIONARY(dictionary) (((dictionary) != NULL) ? (dictionary)->system : NULL)
#define FICL_DICTIONARY_ASSERT(dictionary, expression) FICL_SYSTEM_ASSERT(FICL_SAFE_SYSTEM_FROM_DICTIONARY(dictionary), expression)
/**************************************************************************
d i c t A b o r t D e f i n i t i o n
** Abort a definition in process: reclaim its memory and unlink it
** from the dictionary list. Assumes that there is a smudged
** definition in process...otherwise does nothing.
** NOTE: this function is not smart enough to unlink a word that
** has been successfully defined (ie linked into a hash). It
** only works for defs in process. If the def has been unsmudged,
** nothing happens.
**************************************************************************/
void ficlDictionaryAbortDefinition(ficlDictionary *dictionary)
{
ficlWord *word;
ficlDictionaryLock(dictionary, FICL_TRUE);
word = dictionary->smudge;
if (word->flags & FICL_WORD_SMUDGED)
dictionary->here = (ficlCell *)word->name;
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
d i c t A l i g n
** Align the dictionary's free space pointer
**************************************************************************/
void ficlDictionaryAlign(ficlDictionary *dictionary)
{
dictionary->here = (ficlCell*)ficlAlignPointer(dictionary->here);
}
/**************************************************************************
d i c t A l l o t
** Allocate or remove n chars of dictionary space, with
** checks for underrun and overrun
**************************************************************************/
void ficlDictionaryAllot(ficlDictionary *dictionary, int n)
{
char *here = (char *)dictionary->here;
here += n;
dictionary->here = FICL_POINTER_TO_CELL(here);
}
/**************************************************************************
d i c t A l l o t C e l l s
** Reserve space for the requested number of ficlCells in the
** dictionary. If nficlCells < 0 , removes space from the dictionary.
**************************************************************************/
void ficlDictionaryAllotCells(ficlDictionary *dictionary, int nficlCells)
{
dictionary->here += nficlCells;
}
/**************************************************************************
d i c t A p p e n d C e l l
** Append the specified ficlCell to the dictionary
**************************************************************************/
void ficlDictionaryAppendCell(ficlDictionary *dictionary, ficlCell c)
{
*dictionary->here++ = c;
return;
}
/**************************************************************************
d i c t A p p e n d C h a r
** Append the specified char to the dictionary
**************************************************************************/
void ficlDictionaryAppendCharacter(ficlDictionary *dictionary, char c)
{
char *here = (char *)dictionary->here;
*here++ = c;
dictionary->here = FICL_POINTER_TO_CELL(here);
return;
}
/**************************************************************************
d i c t A p p e n d U N S
** Append the specified ficlUnsigned to the dictionary
**************************************************************************/
void ficlDictionaryAppendUnsigned(ficlDictionary *dictionary, ficlUnsigned u)
{
*dictionary->here++ = FICL_LVALUE_TO_CELL(u);
return;
}
void *ficlDictionaryAppendData(ficlDictionary *dictionary, void *data, ficlInteger length)
{
char *here = (char *)dictionary->here;
char *oldHere = here;
char *from = (char *)data;
if (length == 0)
{
ficlDictionaryAlign(dictionary);
return (char *)dictionary->here;
}
while (length)
{
*here++ = *from++;
length--;
}
*here++ = '\0';
dictionary->here = FICL_POINTER_TO_CELL(here);
ficlDictionaryAlign(dictionary);
return oldHere;
}
/**************************************************************************
d i c t C o p y N a m e
** Copy up to FICL_NAME_LENGTH characters of the name specified by s into
** the dictionary starting at "here", then NULL-terminate the name,
** point "here" to the next available byte, and return the address of
** the beginning of the name. Used by dictAppendWord.
** N O T E S :
** 1. "here" is guaranteed to be aligned after this operation.
** 2. If the string has zero length, align and return "here"
**************************************************************************/
char *ficlDictionaryAppendString(ficlDictionary *dictionary, ficlString s)
{
void *data = FICL_STRING_GET_POINTER(s);
ficlInteger length = FICL_STRING_GET_LENGTH(s);
if (length > FICL_NAME_LENGTH)
length = FICL_NAME_LENGTH;
return (char*)ficlDictionaryAppendData(dictionary, data, length);
}
ficlWord *ficlDictionaryAppendConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value)
{
ficlWord *word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)instruction, FICL_WORD_DEFAULT);
if (word != NULL)
ficlDictionaryAppendUnsigned(dictionary, value);
return word;
}
ficlWord *ficlDictionaryAppend2ConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficl2Integer value)
{
ficlWord *word = ficlDictionaryAppendWord(dictionary, name, (ficlPrimitive)instruction, FICL_WORD_DEFAULT);
if (word != NULL)
{
ficlDictionaryAppendUnsigned(dictionary, FICL_2UNSIGNED_GET_HIGH(value));
ficlDictionaryAppendUnsigned(dictionary, FICL_2UNSIGNED_GET_LOW(value));
}
return word;
}
ficlWord *ficlDictionaryAppendConstant(ficlDictionary *dictionary, char *name, ficlInteger value)
{
ficlString s;
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionaryAppendConstantInstruction(dictionary, s, ficlInstructionConstantParen, value);
}
ficlWord *ficlDictionaryAppend2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value)
{
ficlString s;
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionaryAppend2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, value);
}
ficlWord *ficlDictionarySetConstantInstruction(ficlDictionary *dictionary, ficlString name, ficlInstruction instruction, ficlInteger value)
{
ficlWord *word = ficlDictionaryLookup(dictionary, name);
if (word == NULL)
{
word = ficlDictionaryAppendConstantInstruction(dictionary, name, instruction, value);
}
else
{
word->code = (ficlPrimitive)instruction;
word->param[0] = FICL_LVALUE_TO_CELL(value);
}
return word;
}
ficlWord *ficlDictionarySetConstant(ficlDictionary *dictionary, char *name, ficlInteger value)
{
ficlString s;
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionarySetConstantInstruction(dictionary, s, ficlInstructionConstantParen, value);
}
ficlWord *ficlDictionarySet2ConstantInstruction(ficlDictionary *dictionary, ficlString s, ficlInstruction instruction, ficl2Integer value)
{
ficlWord *word;
word = ficlDictionaryLookup(dictionary, s);
/* only reuse the existing word if we're sure it has space for a 2constant */
if ((word != NULL) &&
((((ficlInstruction)(uintptr_t)word->code) == ficlInstruction2ConstantParen)
#if FICL_WANT_FLOAT
||
(((ficlInstruction)(uintptr_t)word->code) == ficlInstructionF2ConstantParen)
#endif /* FICL_WANT_FLOAT */
)
)
{
word->code = (ficlPrimitive)instruction;
word->param[0].u = FICL_2UNSIGNED_GET_HIGH(value);
word->param[1].u = FICL_2UNSIGNED_GET_LOW(value);
}
else
{
word = ficlDictionaryAppend2ConstantInstruction(dictionary, s, instruction, value);
}
return word;
}
ficlWord *ficlDictionarySet2Constant(ficlDictionary *dictionary, char *name, ficl2Integer value)
{
ficlString s;
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, value);
}
ficlWord *ficlDictionarySetConstantString(ficlDictionary *dictionary, char *name, char *value)
{
ficlString s;
ficl2Integer valueAs2Integer;
FICL_2INTEGER_SET(strlen(value), (intptr_t)value, valueAs2Integer);
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionarySet2ConstantInstruction(dictionary, s, ficlInstruction2ConstantParen, valueAs2Integer);
}
/**************************************************************************
d i c t A p p e n d W o r d
** Create a new word in the dictionary with the specified
** ficlString, code, and flags. Does not require a NULL-terminated
** name.
**************************************************************************/
ficlWord *ficlDictionaryAppendWord(ficlDictionary *dictionary,
ficlString name,
ficlPrimitive code,
ficlUnsigned8 flags)
{
ficlUnsigned8 length = (ficlUnsigned8)FICL_STRING_GET_LENGTH(name);
char *nameCopy;
ficlWord *word;
ficlDictionaryLock(dictionary, FICL_TRUE);
/*
** NOTE: ficlDictionaryAppendString advances "here" as a side-effect.
** It must execute before word is initialized.
*/
nameCopy = ficlDictionaryAppendString(dictionary, name);
word = (ficlWord *)dictionary->here;
dictionary->smudge = word;
word->hash = ficlHashCode(name);
word->code = code;
word->semiParen = ficlInstructionSemiParen;
word->flags = (ficlUnsigned8)(flags | FICL_WORD_SMUDGED);
word->length = length;
word->name = nameCopy;
/*
** Point "here" to first ficlCell of new word's param area...
*/
dictionary->here = word->param;
if (!(flags & FICL_WORD_SMUDGED))
ficlDictionaryUnsmudge(dictionary);
ficlDictionaryLock(dictionary, FICL_FALSE);
return word;
}
/**************************************************************************
d i c t A p p e n d W o r d
** Create a new word in the dictionary with the specified
** name, code, and flags. Name must be NULL-terminated.
**************************************************************************/
ficlWord *ficlDictionaryAppendPrimitive(ficlDictionary *dictionary,
char *name,
ficlPrimitive code,
ficlUnsigned8 flags)
{
ficlString s;
FICL_STRING_SET_FROM_CSTRING(s, name);
return ficlDictionaryAppendWord(dictionary, s, code, flags);
}
ficlWord *ficlDictionarySetPrimitive(ficlDictionary *dictionary,
char *name,
ficlPrimitive code,
ficlUnsigned8 flags)
{
ficlString s;
ficlWord *word;
FICL_STRING_SET_FROM_CSTRING(s, name);
word = ficlDictionaryLookup(dictionary, s);
if (word == NULL)
{
word = ficlDictionaryAppendPrimitive(dictionary, name, code, flags);
}
else
{
word->code = (ficlPrimitive)code;
word->flags = flags;
}
return word;
}
ficlWord *ficlDictionaryAppendInstruction(ficlDictionary *dictionary,
char *name,
ficlInstruction i,
ficlUnsigned8 flags)
{
return ficlDictionaryAppendPrimitive(dictionary, name, (ficlPrimitive)i, (ficlUnsigned8)(FICL_WORD_INSTRUCTION | flags));
}
ficlWord *ficlDictionarySetInstruction(ficlDictionary *dictionary,
char *name,
ficlInstruction i,
ficlUnsigned8 flags)
{
return ficlDictionarySetPrimitive(dictionary, name, (ficlPrimitive)i, (ficlUnsigned8)(FICL_WORD_INSTRUCTION | flags));
}
/**************************************************************************
d i c t C e l l s A v a i l
** Returns the number of empty ficlCells left in the dictionary
**************************************************************************/
int ficlDictionaryCellsAvailable(ficlDictionary *dictionary)
{
return dictionary->size - ficlDictionaryCellsUsed(dictionary);
}
/**************************************************************************
d i c t C e l l s U s e d
** Returns the number of ficlCells consumed in the dicionary
**************************************************************************/
int ficlDictionaryCellsUsed(ficlDictionary *dictionary)
{
return dictionary->here - dictionary->base;
}
/**************************************************************************
d i c t C r e a t e
** Create and initialize a dictionary with the specified number
** of ficlCells capacity, and no hashing (hash size == 1).
**************************************************************************/
ficlDictionary *ficlDictionaryCreate(ficlSystem *system, unsigned size)
{
return ficlDictionaryCreateHashed(system, size, 1);
}
ficlDictionary *ficlDictionaryCreateHashed(ficlSystem *system, unsigned size, unsigned bucketCount)
{
ficlDictionary *dictionary;
size_t nAlloc;
nAlloc = sizeof(ficlDictionary) + (size * sizeof (ficlCell))
+ sizeof(ficlHash) + (bucketCount - 1) * sizeof (ficlWord *);
dictionary = (ficlDictionary*)ficlMalloc(nAlloc);
FICL_SYSTEM_ASSERT(system, dictionary != NULL);
dictionary->size = size;
dictionary->system = system;
ficlDictionaryEmpty(dictionary, bucketCount);
return dictionary;
}
/**************************************************************************
d i c t C r e a t e W o r d l i s t
** Create and initialize an anonymous wordlist
**************************************************************************/
ficlHash *ficlDictionaryCreateWordlist(ficlDictionary *dictionary, int bucketCount)
{
ficlHash *hash;
ficlDictionaryAlign(dictionary);
hash = (ficlHash *)dictionary->here;
ficlDictionaryAllot(dictionary, sizeof (ficlHash)
+ (bucketCount - 1) * sizeof (ficlWord *));
hash->size = bucketCount;
ficlHashReset(hash);
return hash;
}
/**************************************************************************
d i c t D e l e t e
** Free all memory allocated for the given dictionary
**************************************************************************/
void ficlDictionaryDestroy(ficlDictionary *dictionary)
{
FICL_DICTIONARY_ASSERT(dictionary, dictionary != NULL);
ficlFree(dictionary);
return;
}
/**************************************************************************
d i c t E m p t y
** Empty the dictionary, reset its hash table, and reset its search order.
** Clears and (re-)creates the hash table with the size specified by nHash.
**************************************************************************/
void ficlDictionaryEmpty(ficlDictionary *dictionary, unsigned bucketCount)
{
ficlHash *hash;
dictionary->here = dictionary->base;
ficlDictionaryAlign(dictionary);
hash = (ficlHash *)dictionary->here;
ficlDictionaryAllot(dictionary,
sizeof (ficlHash) + (bucketCount - 1) * sizeof (ficlWord *));
hash->size = bucketCount;
ficlHashReset(hash);
dictionary->forthWordlist = hash;
dictionary->smudge = NULL;
ficlDictionaryResetSearchOrder(dictionary);
return;
}
/**************************************************************************
** i s A F i c l W o r d
** Vet a candidate pointer carefully to make sure
** it's not some chunk o' inline data...
** It has to have a name, and it has to look
** like it's in the dictionary address range.
** NOTE: this excludes :noname words!
**************************************************************************/
int ficlDictionaryIsAWord(ficlDictionary *dictionary, ficlWord *word)
{
if ( (((ficlInstruction)(uintptr_t)word) > ficlInstructionInvalid)
&& (((ficlInstruction)(uintptr_t)word) < ficlInstructionLast) )
return 1;
if (!ficlDictionaryIncludes(dictionary, word))
return 0;
if (!ficlDictionaryIncludes(dictionary, word->name))
return 0;
if ((word->link != NULL) && !ficlDictionaryIncludes(dictionary, word->link))
return 0;
if ((word->length <= 0) || (word->name[word->length] != '\0'))
return 0;
if (strlen(word->name) != word->length)
return 0;
return 1;
}
/**************************************************************************
f i n d E n c l o s i n g W o r d
** Given a pointer to something, check to make sure it's an address in the
** dictionary. If so, search backwards until we find something that looks
** like a dictionary header. If successful, return the address of the
** ficlWord found. Otherwise return NULL.
** nSEARCH_CELLS sets the maximum neighborhood this func will search before giving up
**************************************************************************/
#define nSEARCH_CELLS 100
ficlWord *ficlDictionaryFindEnclosingWord(ficlDictionary *dictionary, ficlCell *cell)
{
ficlWord *word;
int i;
if (!ficlDictionaryIncludes(dictionary, (void *)cell))
return NULL;
for (i = nSEARCH_CELLS; i > 0; --i, --cell)
{
word = (ficlWord *)(cell + 1 - (sizeof(ficlWord) / sizeof(ficlCell)));
if (ficlDictionaryIsAWord(dictionary, word))
return word;
}
return NULL;
}
/**************************************************************************
d i c t I n c l u d e s
** Returns FICL_TRUE iff the given pointer is within the address range of
** the dictionary.
**************************************************************************/
int ficlDictionaryIncludes(ficlDictionary *dictionary, void *p)
{
return ((p >= (void *) &dictionary->base)
&& (p < (void *)(&dictionary->base + dictionary->size)));
}
/**************************************************************************
d i c t L o o k u p
** Find the ficlWord that matches the given name and length.
** If found, returns the word's address. Otherwise returns NULL.
** Uses the search order list to search multiple wordlists.
**************************************************************************/
ficlWord *ficlDictionaryLookup(ficlDictionary *dictionary, ficlString name)
{
ficlWord *word = NULL;
ficlHash *hash;
int i;
ficlUnsigned16 hashCode = ficlHashCode(name);
FICL_DICTIONARY_ASSERT(dictionary, dictionary != NULL);
ficlDictionaryLock(dictionary, FICL_TRUE);
for (i = (int)dictionary->wordlistCount - 1; (i >= 0) && (!word); --i)
{
hash = dictionary->wordlists[i];
word = ficlHashLookup(hash, name, hashCode);
}
ficlDictionaryLock(dictionary, FICL_TRUE);
return word;
}
/**************************************************************************
s e e
** TOOLS ( "<spaces>name" -- )
** Display a human-readable representation of the named word's definition.
** The source of the representation (object-code decompilation, source
** block, etc.) and the particular form of the display is implementation
** defined.
**************************************************************************/
/*
** ficlSeeColon (for proctologists only)
** Walks a colon definition, decompiling
** on the fly. Knows about primitive control structures.
*/
char *ficlDictionaryInstructionNames[] =
{
#define FICL_TOKEN(token, description) description,
#define FICL_INSTRUCTION_TOKEN(token, description, flags) description,
#include "ficltokens.h"
#undef FICL_TOKEN
#undef FICL_INSTRUCTION_TOKEN
};
void ficlDictionarySee(ficlDictionary *dictionary, ficlWord *word, ficlCallback *callback)
{
char *trace;
ficlCell *cell = word->param;
ficlCell *param0 = cell;
char buffer[128];
for (; cell->i != ficlInstructionSemiParen; cell++)
{
ficlWord *word = (ficlWord *)(cell->p);
trace = buffer;
if ((void *)cell == (void *)buffer)
*trace++ = '>';
else
*trace++ = ' ';
trace += sprintf(trace, "%3td ", cell - param0);
if (ficlDictionaryIsAWord(dictionary, word))
{
ficlWordKind kind = ficlWordClassify(word);
ficlCell c, c2;
switch (kind)
{
case FICL_WORDKIND_INSTRUCTION:
sprintf(trace, "%s (instruction %ld)", ficlDictionaryInstructionNames[(long)word], (long)word);
break;
case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
c = *++cell;
sprintf(trace, "%s (instruction %ld), with argument %ld (%#lx)", ficlDictionaryInstructionNames[(long)word], (long)word, c.i, c.u);
break;
case FICL_WORDKIND_INSTRUCTION_WORD:
sprintf(trace, "%s :: executes %s (instruction word %ld)", word->name, ficlDictionaryInstructionNames[(long)word->code], (long)word->code);
break;
case FICL_WORDKIND_LITERAL:
c = *++cell;
if (ficlDictionaryIsAWord(dictionary, (ficlWord*)c.p) && (c.i >= ficlInstructionLast))
{
ficlWord *word = (ficlWord *)c.p;
sprintf(trace, "%.*s ( %#jx literal )",
word->length, word->name, (uintmax_t)c.u);
}
else
sprintf(trace, "literal %jd (%#jx)", (intmax_t)c.i, (uintmax_t)c.u);
break;
case FICL_WORDKIND_2LITERAL:
c = *++cell;
c2 = *++cell;
sprintf(trace, "2literal %jd %jd (%#jx %#jx)", (intmax_t)c2.i, (intmax_t)c.i, (uintmax_t)c2.u, (uintmax_t)c.u);
break;
#if FICL_WANT_FLOAT
case FICL_WORDKIND_FLITERAL:
c = *++cell;
sprintf(trace, "fliteral %f (%#jx)", c.f, (uintmax_t)c.u);
break;
#endif /* FICL_WANT_FLOAT */
case FICL_WORDKIND_STRING_LITERAL:
{
ficlCountedString *counted = (ficlCountedString *)(void *)++cell;
cell = (ficlCell *)ficlAlignPointer(counted->text + counted->length + 1) - 1;
sprintf(trace, "s\" %.*s\"", counted->length, counted->text);
}
break;
case FICL_WORDKIND_CSTRING_LITERAL:
{
ficlCountedString *counted = (ficlCountedString *)(void *)++cell;
cell = (ficlCell *)ficlAlignPointer(counted->text + counted->length + 1) - 1;
sprintf(trace, "c\" %.*s\"", counted->length, counted->text);
}
break;
case FICL_WORDKIND_BRANCH0:
c = *++cell;
sprintf(trace, "branch0 %td", cell + c.i - param0);
break;
case FICL_WORDKIND_BRANCH:
c = *++cell;
sprintf(trace, "branch %td", cell + c.i - param0);
break;
case FICL_WORDKIND_QDO:
c = *++cell;
sprintf(trace, "?do (leave %td)", (ficlCell *)c.p - param0);
break;
case FICL_WORDKIND_DO:
c = *++cell;
sprintf(trace, "do (leave %td)", (ficlCell *)c.p - param0);
break;
case FICL_WORDKIND_LOOP:
c = *++cell;
sprintf(trace, "loop (branch %td)", cell + c.i - param0);
break;
case FICL_WORDKIND_OF:
c = *++cell;
sprintf(trace, "of (branch %td)", cell + c.i - param0);
break;
case FICL_WORDKIND_PLOOP:
c = *++cell;
sprintf(trace, "+loop (branch %td)", cell + c.i - param0);
break;
default:
sprintf(trace, "%.*s", word->length, word->name);
break;
}
}
else /* probably not a word - punt and print value */
{
sprintf(trace, "%ld ( %#lx )", cell->i, cell->u);
}
ficlCallbackTextOut(callback, buffer);
ficlCallbackTextOut(callback, "\n");
}
ficlCallbackTextOut(callback, ";\n");
}
/**************************************************************************
d i c t R e s e t S e a r c h O r d e r
** Initialize the dictionary search order list to sane state
**************************************************************************/
void ficlDictionaryResetSearchOrder(ficlDictionary *dictionary)
{
FICL_DICTIONARY_ASSERT(dictionary, dictionary);
dictionary->compilationWordlist = dictionary->forthWordlist;
dictionary->wordlistCount = 1;
dictionary->wordlists[0] = dictionary->forthWordlist;
return;
}
/**************************************************************************
d i c t S e t F l a g s
** Changes the flags field of the most recently defined word:
** Set all bits that are ones in the set parameter.
**************************************************************************/
void ficlDictionarySetFlags(ficlDictionary *dictionary, ficlUnsigned8 set)
{
FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
dictionary->smudge->flags |= set;
return;
}
/**************************************************************************
d i c t C l e a r F l a g s
** Changes the flags field of the most recently defined word:
** Clear all bits that are ones in the clear parameter.
**************************************************************************/
void ficlDictionaryClearFlags(ficlDictionary *dictionary, ficlUnsigned8 clear)
{
FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
dictionary->smudge->flags &= ~clear;
return;
}
/**************************************************************************
d i c t S e t I m m e d i a t e
** Set the most recently defined word as IMMEDIATE
**************************************************************************/
void ficlDictionarySetImmediate(ficlDictionary *dictionary)
{
FICL_DICTIONARY_ASSERT(dictionary, dictionary->smudge);
dictionary->smudge->flags |= FICL_WORD_IMMEDIATE;
return;
}
/**************************************************************************
d i c t U n s m u d g e
** Completes the definition of a word by linking it
** into the main list
**************************************************************************/
void ficlDictionaryUnsmudge(ficlDictionary *dictionary)
{
ficlWord *word = dictionary->smudge;
ficlHash *hash = dictionary->compilationWordlist;
FICL_DICTIONARY_ASSERT(dictionary, hash);
FICL_DICTIONARY_ASSERT(dictionary, word);
/*
** :noname words never get linked into the list...
*/
if (word->length > 0)
ficlHashInsertWord(hash, word);
word->flags &= ~(FICL_WORD_SMUDGED);
return;
}
/**************************************************************************
d i c t W h e r e
** Returns the value of the HERE pointer -- the address
** of the next free ficlCell in the dictionary
**************************************************************************/
ficlCell *ficlDictionaryWhere(ficlDictionary *dictionary)
{
return dictionary->here;
}