394 lines
13 KiB
C
394 lines
13 KiB
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.9 2001/12/05 07:21:34 jsadler 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.
|
|
*/
|
|
|
|
/* $FreeBSD$ */
|
|
|
|
#include <string.h>
|
|
#include "ficl.h"
|
|
#include "math64.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 definitions(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *pDict = vmGetDict(pVM);
|
|
|
|
assert(pDict);
|
|
if (pDict->nLists < 1)
|
|
{
|
|
vmThrowErr(pVM, "DEFINITIONS error - empty search order");
|
|
}
|
|
|
|
pDict->pCompile = pDict->pSearch[pDict->nLists-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 forthWordlist(FICL_VM *pVM)
|
|
{
|
|
FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
|
|
stackPushPtr(pVM->pStack, pHash);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
g e t - c u r r e n t
|
|
** SEARCH ( -- wid )
|
|
** Return wid, the identifier of the compilation word list.
|
|
**************************************************************************/
|
|
static void getCurrent(FICL_VM *pVM)
|
|
{
|
|
ficlLockDictionary(TRUE);
|
|
stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile);
|
|
ficlLockDictionary(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 getOrder(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *pDict = vmGetDict(pVM);
|
|
int nLists = pDict->nLists;
|
|
int i;
|
|
|
|
ficlLockDictionary(TRUE);
|
|
for (i = 0; i < nLists; i++)
|
|
{
|
|
stackPushPtr(pVM->pStack, pDict->pSearch[i]);
|
|
}
|
|
|
|
stackPushUNS(pVM->pStack, nLists);
|
|
ficlLockDictionary(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 searchWordlist(FICL_VM *pVM)
|
|
{
|
|
STRINGINFO si;
|
|
UNS16 hashCode;
|
|
FICL_WORD *pFW;
|
|
FICL_HASH *pHash = stackPopPtr(pVM->pStack);
|
|
|
|
si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
|
|
si.cp = stackPopPtr(pVM->pStack);
|
|
hashCode = hashHashCode(si);
|
|
|
|
ficlLockDictionary(TRUE);
|
|
pFW = hashLookup(pHash, si, hashCode);
|
|
ficlLockDictionary(FALSE);
|
|
|
|
if (pFW)
|
|
{
|
|
stackPushPtr(pVM->pStack, pFW);
|
|
stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
|
|
}
|
|
else
|
|
{
|
|
stackPushUNS(pVM->pStack, 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 setCurrent(FICL_VM *pVM)
|
|
{
|
|
FICL_HASH *pHash = stackPopPtr(pVM->pStack);
|
|
FICL_DICT *pDict = vmGetDict(pVM);
|
|
ficlLockDictionary(TRUE);
|
|
pDict->pCompile = pHash;
|
|
ficlLockDictionary(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 setOrder(FICL_VM *pVM)
|
|
{
|
|
int i;
|
|
int nLists = stackPopINT(pVM->pStack);
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
|
|
if (nLists > FICL_DEFAULT_VOCS)
|
|
{
|
|
vmThrowErr(pVM, "set-order error: list would be too large");
|
|
}
|
|
|
|
ficlLockDictionary(TRUE);
|
|
|
|
if (nLists >= 0)
|
|
{
|
|
dp->nLists = nLists;
|
|
for (i = nLists-1; i >= 0; --i)
|
|
{
|
|
dp->pSearch[i] = stackPopPtr(pVM->pStack);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
dictResetSearchOrder(dp);
|
|
}
|
|
|
|
ficlLockDictionary(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 ficlWordlist(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
FICL_HASH *pHash;
|
|
FICL_UNS nBuckets;
|
|
|
|
#if FICL_ROBUST > 1
|
|
vmCheckStack(pVM, 1, 1);
|
|
#endif
|
|
nBuckets = stackPopUNS(pVM->pStack);
|
|
pHash = dictCreateWordlist(dp, nBuckets);
|
|
stackPushPtr(pVM->pStack, pHash);
|
|
return;
|
|
}
|
|
|
|
|
|
/**************************************************************************
|
|
S E A R C H >
|
|
** ficl ( -- wid )
|
|
** Pop wid off the search order. Error if the search order is empty
|
|
**************************************************************************/
|
|
static void searchPop(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
int nLists;
|
|
|
|
ficlLockDictionary(TRUE);
|
|
nLists = dp->nLists;
|
|
if (nLists == 0)
|
|
{
|
|
vmThrowErr(pVM, "search> error: empty search order");
|
|
}
|
|
stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
|
|
ficlLockDictionary(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 searchPush(FICL_VM *pVM)
|
|
{
|
|
FICL_DICT *dp = vmGetDict(pVM);
|
|
|
|
ficlLockDictionary(TRUE);
|
|
if (dp->nLists > FICL_DEFAULT_VOCS)
|
|
{
|
|
vmThrowErr(pVM, ">search error: search order overflow");
|
|
}
|
|
dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
|
|
ficlLockDictionary(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 widGetName(FICL_VM *pVM)
|
|
{
|
|
FICL_HASH *pHash = vmPop(pVM).p;
|
|
char *cp = pHash->name;
|
|
FICL_INT len = 0;
|
|
|
|
if (cp)
|
|
len = strlen(cp);
|
|
|
|
vmPush(pVM, LVALUEtoCELL(cp));
|
|
vmPush(pVM, LVALUEtoCELL(len));
|
|
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 widSetName(FICL_VM *pVM)
|
|
{
|
|
char *cp = (char *)vmPop(pVM).p;
|
|
FICL_HASH *pHash = vmPop(pVM).p;
|
|
pHash->name = cp;
|
|
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 setParentWid(FICL_VM *pVM)
|
|
{
|
|
FICL_HASH *parent, *child;
|
|
#if FICL_ROBUST > 1
|
|
vmCheckStack(pVM, 2, 0);
|
|
#endif
|
|
child = (FICL_HASH *)stackPopPtr(pVM->pStack);
|
|
parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
|
|
|
|
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 ficlCompileSearch(FICL_SYSTEM *pSys)
|
|
{
|
|
FICL_DICT *dp = pSys->dp;
|
|
assert (dp);
|
|
|
|
/*
|
|
** optional SEARCH-ORDER word set
|
|
*/
|
|
dictAppendWord(dp, ">search", searchPush, FW_DEFAULT);
|
|
dictAppendWord(dp, "search>", searchPop, FW_DEFAULT);
|
|
dictAppendWord(dp, "definitions",
|
|
definitions, FW_DEFAULT);
|
|
dictAppendWord(dp, "forth-wordlist",
|
|
forthWordlist, FW_DEFAULT);
|
|
dictAppendWord(dp, "get-current",
|
|
getCurrent, FW_DEFAULT);
|
|
dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT);
|
|
dictAppendWord(dp, "search-wordlist",
|
|
searchWordlist, FW_DEFAULT);
|
|
dictAppendWord(dp, "set-current",
|
|
setCurrent, FW_DEFAULT);
|
|
dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT);
|
|
dictAppendWord(dp, "ficl-wordlist",
|
|
ficlWordlist, FW_DEFAULT);
|
|
|
|
/*
|
|
** Set SEARCH environment query values
|
|
*/
|
|
ficlSetEnv(pSys, "search-order", FICL_TRUE);
|
|
ficlSetEnv(pSys, "search-order-ext", FICL_TRUE);
|
|
ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS);
|
|
|
|
dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT);
|
|
dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT);
|
|
dictAppendWord(dp, "wid-set-super",
|
|
setParentWid, FW_DEFAULT);
|
|
return;
|
|
}
|
|
|