ref: 7c76dac1b268038f567939a70a18228e790a5cbc
dir: /search.c/
/*******************************************************************
** s e a r c h . c
** Forth Inspired Command Language
** ANS Forth SEARCH and SEARCH-EXT word-set written in C
** Author: John Sadler (john_sadler@alum.mit.edu)
** Created: 6 June 2000
** $Id: search.c,v 1.12 2010/12/02 13:56:43 asau Exp $
*******************************************************************/
/*
** 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 <string.h>
#include "ficl.h"
/**************************************************************************
d e f i n i t i o n s
** SEARCH ( -- )
** Make the compilation word list the same as the first word list in the
** search order. Specifies that the names of subsequent definitions will
** be placed in the compilation word list. Subsequent changes in the search
** order will not affect the compilation word list.
**************************************************************************/
static void ficlPrimitiveDefinitions(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
FICL_VM_ASSERT(vm, dictionary);
if (dictionary->wordlistCount < 1)
{
ficlVmThrowError(vm, "DEFINITIONS error - empty search order");
}
dictionary->compilationWordlist = dictionary->wordlists[dictionary->wordlistCount-1];
return;
}
/**************************************************************************
f o r t h - w o r d l i s t
** SEARCH ( -- wid )
** Return wid, the identifier of the word list that includes all standard
** words provided by the implementation. This word list is initially the
** compilation word list and is part of the initial search order.
**************************************************************************/
static void ficlPrimitiveForthWordlist(ficlVm *vm)
{
ficlHash *hash = ficlVmGetDictionary(vm)->forthWordlist;
ficlStackPushPointer(vm->dataStack, hash);
return;
}
/**************************************************************************
g e t - c u r r e n t
** SEARCH ( -- wid )
** Return wid, the identifier of the compilation word list.
**************************************************************************/
static void ficlPrimitiveGetCurrent(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
ficlDictionaryLock(dictionary, FICL_TRUE);
ficlStackPushPointer(vm->dataStack, dictionary->compilationWordlist);
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
g e t - o r d e r
** SEARCH ( -- widn ... wid1 n )
** Returns the number of word lists n in the search order and the word list
** identifiers widn ... wid1 identifying these word lists. wid1 identifies
** the word list that is searched first, and widn the word list that is
** searched last. The search order is unaffected.
**************************************************************************/
static void ficlPrimitiveGetOrder(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
int wordlistCount = dictionary->wordlistCount;
int i;
ficlDictionaryLock(dictionary, FICL_TRUE);
for (i = 0; i < wordlistCount; i++)
{
ficlStackPushPointer(vm->dataStack, dictionary->wordlists[i]);
}
ficlStackPushUnsigned(vm->dataStack, wordlistCount);
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
s e a r c h - w o r d l i s t
** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
** Find the definition identified by the string c-addr u in the word list
** identified by wid. If the definition is not found, return zero. If the
** definition is found, return its execution token xt and one (1) if the
** definition is immediate, minus-one (-1) otherwise.
**************************************************************************/
static void ficlPrimitiveSearchWordlist(ficlVm *vm)
{
ficlString name;
ficlUnsigned16 hashCode;
ficlWord *word;
ficlHash *hash = (ficlHash*)ficlStackPopPointer(vm->dataStack);
name.length = (ficlUnsigned8)ficlStackPopUnsigned(vm->dataStack);
name.text = (char*)ficlStackPopPointer(vm->dataStack);
hashCode = ficlHashCode(name);
ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_TRUE);
word = ficlHashLookup(hash, name, hashCode);
ficlDictionaryLock(ficlVmGetDictionary(vm), FICL_FALSE);
if (word)
{
ficlStackPushPointer(vm->dataStack, word);
ficlStackPushInteger(vm->dataStack, (ficlWordIsImmediate(word) ? 1 : -1));
}
else
{
ficlStackPushUnsigned(vm->dataStack, 0);
}
return;
}
/**************************************************************************
s e t - c u r r e n t
** SEARCH ( wid -- )
** Set the compilation word list to the word list identified by wid.
**************************************************************************/
static void ficlPrimitiveSetCurrent(ficlVm *vm)
{
ficlHash *hash = (ficlHash*)ficlStackPopPointer(vm->dataStack);
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
ficlDictionaryLock(dictionary, FICL_TRUE);
dictionary->compilationWordlist = hash;
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
s e t - o r d e r
** SEARCH ( widn ... wid1 n -- )
** Set the search order to the word lists identified by widn ... wid1.
** Subsequently, word list wid1 will be searched first, and word list
** widn searched last. If n is zero, empty the search order. If n is minus
** one, set the search order to the implementation-defined minimum
** search order. The minimum search order shall include the words
** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
** be at least eight.
**************************************************************************/
static void ficlPrimitiveSetOrder(ficlVm *vm)
{
int i;
int wordlistCount = ficlStackPopInteger(vm->dataStack);
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
if (wordlistCount > FICL_MAX_WORDLISTS)
{
ficlVmThrowError(vm, "set-order error: list would be too large");
}
ficlDictionaryLock(dictionary, FICL_TRUE);
if (wordlistCount >= 0)
{
dictionary->wordlistCount = wordlistCount;
for (i = wordlistCount-1; i >= 0; --i)
{
dictionary->wordlists[i] = (ficlHash*)ficlStackPopPointer(vm->dataStack);
}
}
else
{
ficlDictionaryResetSearchOrder(dictionary);
}
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
f i c l - w o r d l i s t
** SEARCH ( -- wid )
** Create a new empty word list, returning its word list identifier wid.
** The new word list may be returned from a pool of preallocated word
** lists or may be dynamically allocated in data space. A system shall
** allow the creation of at least 8 new word lists in addition to any
** provided as part of the system.
** Notes:
** 1. Ficl creates a new single-list hash in the dictionary and returns
** its address.
** 2. ficl-wordlist takes an arg off the stack indicating the number of
** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
** : wordlist 1 ficl-wordlist ;
**************************************************************************/
static void ficlPrimitiveFiclWordlist(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
ficlHash *hash;
ficlUnsigned nBuckets;
FICL_STACK_CHECK(vm->dataStack, 1, 1);
nBuckets = ficlStackPopUnsigned(vm->dataStack);
hash = ficlDictionaryCreateWordlist(dictionary, nBuckets);
ficlStackPushPointer(vm->dataStack, hash);
return;
}
/**************************************************************************
S E A R C H >
** Ficl ( -- wid )
** Pop wid off the search order. Error if the search order is empty
**************************************************************************/
static void ficlPrimitiveSearchPop(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
int wordlistCount;
ficlDictionaryLock(dictionary, FICL_TRUE);
wordlistCount = dictionary->wordlistCount;
if (wordlistCount == 0)
{
ficlVmThrowError(vm, "search> error: empty search order");
}
ficlStackPushPointer(vm->dataStack, dictionary->wordlists[--dictionary->wordlistCount]);
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
> S E A R C H
** Ficl ( wid -- )
** Push wid onto the search order. Error if the search order is full.
**************************************************************************/
static void ficlPrimitiveSearchPush(ficlVm *vm)
{
ficlDictionary *dictionary = ficlVmGetDictionary(vm);
ficlDictionaryLock(dictionary, FICL_TRUE);
if (dictionary->wordlistCount > FICL_MAX_WORDLISTS)
{
ficlVmThrowError(vm, ">search error: search order overflow");
}
dictionary->wordlists[dictionary->wordlistCount++] = (ficlHash*)ficlStackPopPointer(vm->dataStack);
ficlDictionaryLock(dictionary, FICL_FALSE);
return;
}
/**************************************************************************
W I D - G E T - N A M E
** Ficl ( wid -- c-addr u )
** Get wid's (optional) name and push onto stack as a counted string
**************************************************************************/
static void ficlPrimitiveWidGetName(ficlVm *vm)
{
ficlHash *hash;
char *name;
ficlInteger length;
hash = (ficlHash*)ficlVmPop(vm).p;
name = hash->name;
if (name != NULL)
length = strlen(name);
else
length = 0;
ficlVmPush(vm, FICL_LVALUE_TO_CELL(name));
ficlVmPush(vm, FICL_LVALUE_TO_CELL(length));
return;
}
/**************************************************************************
W I D - S E T - N A M E
** Ficl ( wid c-addr -- )
** Set wid's name pointer to the \0 terminated string address supplied
**************************************************************************/
static void ficlPrimitiveWidSetName(ficlVm *vm)
{
char *name = (char *)ficlVmPop(vm).p;
ficlHash *hash = (ficlHash*)ficlVmPop(vm).p;
hash->name = name;
return;
}
/**************************************************************************
setParentWid
** Ficl
** setparentwid ( parent-wid wid -- )
** Set WID's link field to the parent-wid. search-wordlist will
** iterate through all the links when finding words in the child wid.
**************************************************************************/
static void ficlPrimitiveSetParentWid(ficlVm *vm)
{
ficlHash *parent, *child;
FICL_STACK_CHECK(vm->dataStack, 2, 0);
child = (ficlHash *)ficlStackPopPointer(vm->dataStack);
parent = (ficlHash *)ficlStackPopPointer(vm->dataStack);
child->link = parent;
return;
}
/**************************************************************************
f i c l C o m p i l e S e a r c h
** Builds the primitive wordset and the environment-query namespace.
**************************************************************************/
void ficlSystemCompileSearch(ficlSystem *system)
{
ficlDictionary *dictionary = ficlSystemGetDictionary(system);
ficlDictionary *environment = ficlSystemGetEnvironment(system);
FICL_SYSTEM_ASSERT(system, dictionary);
FICL_SYSTEM_ASSERT(system, environment);
/*
** optional SEARCH-ORDER word set
*/
ficlDictionarySetPrimitive(dictionary, ">search", ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "search>", ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "definitions",
ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "get-current",
ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "get-order", ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "search-wordlist",
ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "set-current",
ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "set-order", ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);
/*
** Set SEARCH environment query values
*/
ficlDictionarySetConstant(environment, "search-order", FICL_TRUE);
ficlDictionarySetConstant(environment, "search-order-ext", FICL_TRUE);
ficlDictionarySetConstant(environment, "wordlists", FICL_MAX_WORDLISTS);
ficlDictionarySetPrimitive(dictionary, "wid-get-name", ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "wid-set-name", ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
ficlDictionarySetPrimitive(dictionary, "wid-set-super",
ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
return;
}