176116Sdcs/******************************************************************* 276116Sdcs** s e a r c h . c 376116Sdcs** Forth Inspired Command Language 476116Sdcs** ANS Forth SEARCH and SEARCH-EXT word-set written in C 576116Sdcs** Author: John Sadler (john_sadler@alum.mit.edu) 676116Sdcs** Created: 6 June 2000 794290Sdcs** $Id: search.c,v 1.9 2001/12/05 07:21:34 jsadler Exp $ 876116Sdcs*******************************************************************/ 976116Sdcs/* 1076116Sdcs** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 1176116Sdcs** All rights reserved. 1276116Sdcs** 1376116Sdcs** Get the latest Ficl release at http://ficl.sourceforge.net 1476116Sdcs** 1594290Sdcs** I am interested in hearing from anyone who uses ficl. If you have 1694290Sdcs** a problem, a success story, a defect, an enhancement request, or 1794290Sdcs** if you would like to contribute to the ficl release, please 1894290Sdcs** contact me by email at the address above. 1994290Sdcs** 2076116Sdcs** L I C E N S E and D I S C L A I M E R 2176116Sdcs** 2276116Sdcs** Redistribution and use in source and binary forms, with or without 2376116Sdcs** modification, are permitted provided that the following conditions 2476116Sdcs** are met: 2576116Sdcs** 1. Redistributions of source code must retain the above copyright 2676116Sdcs** notice, this list of conditions and the following disclaimer. 2776116Sdcs** 2. Redistributions in binary form must reproduce the above copyright 2876116Sdcs** notice, this list of conditions and the following disclaimer in the 2976116Sdcs** documentation and/or other materials provided with the distribution. 3076116Sdcs** 3176116Sdcs** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 3276116Sdcs** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 3376116Sdcs** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 3476116Sdcs** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 3576116Sdcs** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 3676116Sdcs** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 3776116Sdcs** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 3876116Sdcs** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 3976116Sdcs** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 4076116Sdcs** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 4176116Sdcs** SUCH DAMAGE. 4276116Sdcs*/ 4376116Sdcs 4476116Sdcs/* $FreeBSD: stable/11/stand/ficl/search.c 94290 2002-04-09 17:45:28Z dcs $ */ 4576116Sdcs 4676116Sdcs#include <string.h> 4776116Sdcs#include "ficl.h" 4876116Sdcs#include "math64.h" 4976116Sdcs 5076116Sdcs/************************************************************************** 5176116Sdcs d e f i n i t i o n s 5276116Sdcs** SEARCH ( -- ) 5376116Sdcs** Make the compilation word list the same as the first word list in the 5476116Sdcs** search order. Specifies that the names of subsequent definitions will 5576116Sdcs** be placed in the compilation word list. Subsequent changes in the search 5676116Sdcs** order will not affect the compilation word list. 5776116Sdcs**************************************************************************/ 5876116Sdcsstatic void definitions(FICL_VM *pVM) 5976116Sdcs{ 6094290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 6176116Sdcs 6276116Sdcs assert(pDict); 6376116Sdcs if (pDict->nLists < 1) 6476116Sdcs { 6576116Sdcs vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 6676116Sdcs } 6776116Sdcs 6876116Sdcs pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 6976116Sdcs return; 7076116Sdcs} 7176116Sdcs 7276116Sdcs 7376116Sdcs/************************************************************************** 7476116Sdcs f o r t h - w o r d l i s t 7576116Sdcs** SEARCH ( -- wid ) 7676116Sdcs** Return wid, the identifier of the word list that includes all standard 7776116Sdcs** words provided by the implementation. This word list is initially the 7876116Sdcs** compilation word list and is part of the initial search order. 7976116Sdcs**************************************************************************/ 8076116Sdcsstatic void forthWordlist(FICL_VM *pVM) 8176116Sdcs{ 8294290Sdcs FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; 8376116Sdcs stackPushPtr(pVM->pStack, pHash); 8476116Sdcs return; 8576116Sdcs} 8676116Sdcs 8776116Sdcs 8876116Sdcs/************************************************************************** 8976116Sdcs g e t - c u r r e n t 9076116Sdcs** SEARCH ( -- wid ) 9176116Sdcs** Return wid, the identifier of the compilation word list. 9276116Sdcs**************************************************************************/ 9376116Sdcsstatic void getCurrent(FICL_VM *pVM) 9476116Sdcs{ 9576116Sdcs ficlLockDictionary(TRUE); 9694290Sdcs stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile); 9776116Sdcs ficlLockDictionary(FALSE); 9876116Sdcs return; 9976116Sdcs} 10076116Sdcs 10176116Sdcs 10276116Sdcs/************************************************************************** 10376116Sdcs g e t - o r d e r 10476116Sdcs** SEARCH ( -- widn ... wid1 n ) 10576116Sdcs** Returns the number of word lists n in the search order and the word list 10676116Sdcs** identifiers widn ... wid1 identifying these word lists. wid1 identifies 10776116Sdcs** the word list that is searched first, and widn the word list that is 10876116Sdcs** searched last. The search order is unaffected. 10976116Sdcs**************************************************************************/ 11076116Sdcsstatic void getOrder(FICL_VM *pVM) 11176116Sdcs{ 11294290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 11376116Sdcs int nLists = pDict->nLists; 11476116Sdcs int i; 11576116Sdcs 11676116Sdcs ficlLockDictionary(TRUE); 11776116Sdcs for (i = 0; i < nLists; i++) 11876116Sdcs { 11976116Sdcs stackPushPtr(pVM->pStack, pDict->pSearch[i]); 12076116Sdcs } 12176116Sdcs 12276116Sdcs stackPushUNS(pVM->pStack, nLists); 12376116Sdcs ficlLockDictionary(FALSE); 12476116Sdcs return; 12576116Sdcs} 12676116Sdcs 12776116Sdcs 12876116Sdcs/************************************************************************** 12976116Sdcs s e a r c h - w o r d l i s t 13076116Sdcs** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 13176116Sdcs** Find the definition identified by the string c-addr u in the word list 13276116Sdcs** identified by wid. If the definition is not found, return zero. If the 13376116Sdcs** definition is found, return its execution token xt and one (1) if the 13476116Sdcs** definition is immediate, minus-one (-1) otherwise. 13576116Sdcs**************************************************************************/ 13676116Sdcsstatic void searchWordlist(FICL_VM *pVM) 13776116Sdcs{ 13876116Sdcs STRINGINFO si; 13976116Sdcs UNS16 hashCode; 14076116Sdcs FICL_WORD *pFW; 14176116Sdcs FICL_HASH *pHash = stackPopPtr(pVM->pStack); 14276116Sdcs 14376116Sdcs si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 14476116Sdcs si.cp = stackPopPtr(pVM->pStack); 14576116Sdcs hashCode = hashHashCode(si); 14676116Sdcs 14776116Sdcs ficlLockDictionary(TRUE); 14876116Sdcs pFW = hashLookup(pHash, si, hashCode); 14976116Sdcs ficlLockDictionary(FALSE); 15076116Sdcs 15176116Sdcs if (pFW) 15276116Sdcs { 15376116Sdcs stackPushPtr(pVM->pStack, pFW); 15476116Sdcs stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 15576116Sdcs } 15676116Sdcs else 15776116Sdcs { 15876116Sdcs stackPushUNS(pVM->pStack, 0); 15976116Sdcs } 16076116Sdcs 16176116Sdcs return; 16276116Sdcs} 16376116Sdcs 16476116Sdcs 16576116Sdcs/************************************************************************** 16676116Sdcs s e t - c u r r e n t 16776116Sdcs** SEARCH ( wid -- ) 16876116Sdcs** Set the compilation word list to the word list identified by wid. 16976116Sdcs**************************************************************************/ 17076116Sdcsstatic void setCurrent(FICL_VM *pVM) 17176116Sdcs{ 17276116Sdcs FICL_HASH *pHash = stackPopPtr(pVM->pStack); 17394290Sdcs FICL_DICT *pDict = vmGetDict(pVM); 17476116Sdcs ficlLockDictionary(TRUE); 17576116Sdcs pDict->pCompile = pHash; 17676116Sdcs ficlLockDictionary(FALSE); 17776116Sdcs return; 17876116Sdcs} 17976116Sdcs 18076116Sdcs 18176116Sdcs/************************************************************************** 18276116Sdcs s e t - o r d e r 18376116Sdcs** SEARCH ( widn ... wid1 n -- ) 18476116Sdcs** Set the search order to the word lists identified by widn ... wid1. 18576116Sdcs** Subsequently, word list wid1 will be searched first, and word list 18676116Sdcs** widn searched last. If n is zero, empty the search order. If n is minus 18776116Sdcs** one, set the search order to the implementation-defined minimum 18876116Sdcs** search order. The minimum search order shall include the words 18976116Sdcs** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 19076116Sdcs** be at least eight. 19176116Sdcs**************************************************************************/ 19276116Sdcsstatic void setOrder(FICL_VM *pVM) 19376116Sdcs{ 19476116Sdcs int i; 19576116Sdcs int nLists = stackPopINT(pVM->pStack); 19694290Sdcs FICL_DICT *dp = vmGetDict(pVM); 19776116Sdcs 19876116Sdcs if (nLists > FICL_DEFAULT_VOCS) 19976116Sdcs { 20076116Sdcs vmThrowErr(pVM, "set-order error: list would be too large"); 20176116Sdcs } 20276116Sdcs 20376116Sdcs ficlLockDictionary(TRUE); 20476116Sdcs 20576116Sdcs if (nLists >= 0) 20676116Sdcs { 20776116Sdcs dp->nLists = nLists; 20876116Sdcs for (i = nLists-1; i >= 0; --i) 20976116Sdcs { 21076116Sdcs dp->pSearch[i] = stackPopPtr(pVM->pStack); 21176116Sdcs } 21276116Sdcs } 21376116Sdcs else 21476116Sdcs { 21576116Sdcs dictResetSearchOrder(dp); 21676116Sdcs } 21776116Sdcs 21876116Sdcs ficlLockDictionary(FALSE); 21976116Sdcs return; 22076116Sdcs} 22176116Sdcs 22276116Sdcs 22376116Sdcs/************************************************************************** 22476116Sdcs f i c l - w o r d l i s t 22576116Sdcs** SEARCH ( -- wid ) 22676116Sdcs** Create a new empty word list, returning its word list identifier wid. 22776116Sdcs** The new word list may be returned from a pool of preallocated word 22876116Sdcs** lists or may be dynamically allocated in data space. A system shall 22976116Sdcs** allow the creation of at least 8 new word lists in addition to any 23076116Sdcs** provided as part of the system. 23176116Sdcs** Notes: 23276116Sdcs** 1. ficl creates a new single-list hash in the dictionary and returns 23376116Sdcs** its address. 23476116Sdcs** 2. ficl-wordlist takes an arg off the stack indicating the number of 23576116Sdcs** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 23676116Sdcs** : wordlist 1 ficl-wordlist ; 23776116Sdcs**************************************************************************/ 23876116Sdcsstatic void ficlWordlist(FICL_VM *pVM) 23976116Sdcs{ 24094290Sdcs FICL_DICT *dp = vmGetDict(pVM); 24176116Sdcs FICL_HASH *pHash; 24276116Sdcs FICL_UNS nBuckets; 24376116Sdcs 24476116Sdcs#if FICL_ROBUST > 1 24576116Sdcs vmCheckStack(pVM, 1, 1); 24676116Sdcs#endif 24776116Sdcs nBuckets = stackPopUNS(pVM->pStack); 24876116Sdcs pHash = dictCreateWordlist(dp, nBuckets); 24976116Sdcs stackPushPtr(pVM->pStack, pHash); 25076116Sdcs return; 25176116Sdcs} 25276116Sdcs 25376116Sdcs 25476116Sdcs/************************************************************************** 25576116Sdcs S E A R C H > 25676116Sdcs** ficl ( -- wid ) 25776116Sdcs** Pop wid off the search order. Error if the search order is empty 25876116Sdcs**************************************************************************/ 25976116Sdcsstatic void searchPop(FICL_VM *pVM) 26076116Sdcs{ 26194290Sdcs FICL_DICT *dp = vmGetDict(pVM); 26276116Sdcs int nLists; 26376116Sdcs 26476116Sdcs ficlLockDictionary(TRUE); 26576116Sdcs nLists = dp->nLists; 26676116Sdcs if (nLists == 0) 26776116Sdcs { 26876116Sdcs vmThrowErr(pVM, "search> error: empty search order"); 26976116Sdcs } 27076116Sdcs stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 27176116Sdcs ficlLockDictionary(FALSE); 27276116Sdcs return; 27376116Sdcs} 27476116Sdcs 27576116Sdcs 27676116Sdcs/************************************************************************** 27776116Sdcs > S E A R C H 27876116Sdcs** ficl ( wid -- ) 27976116Sdcs** Push wid onto the search order. Error if the search order is full. 28076116Sdcs**************************************************************************/ 28176116Sdcsstatic void searchPush(FICL_VM *pVM) 28276116Sdcs{ 28394290Sdcs FICL_DICT *dp = vmGetDict(pVM); 28476116Sdcs 28576116Sdcs ficlLockDictionary(TRUE); 28676116Sdcs if (dp->nLists > FICL_DEFAULT_VOCS) 28776116Sdcs { 28876116Sdcs vmThrowErr(pVM, ">search error: search order overflow"); 28976116Sdcs } 29076116Sdcs dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 29176116Sdcs ficlLockDictionary(FALSE); 29276116Sdcs return; 29376116Sdcs} 29476116Sdcs 29576116Sdcs 29676116Sdcs/************************************************************************** 29776116Sdcs W I D - G E T - N A M E 29876116Sdcs** ficl ( wid -- c-addr u ) 29976116Sdcs** Get wid's (optional) name and push onto stack as a counted string 30076116Sdcs**************************************************************************/ 30176116Sdcsstatic void widGetName(FICL_VM *pVM) 30276116Sdcs{ 30376116Sdcs FICL_HASH *pHash = vmPop(pVM).p; 30476116Sdcs char *cp = pHash->name; 30594290Sdcs FICL_INT len = 0; 30676116Sdcs 30776116Sdcs if (cp) 30876116Sdcs len = strlen(cp); 30976116Sdcs 31076116Sdcs vmPush(pVM, LVALUEtoCELL(cp)); 31176116Sdcs vmPush(pVM, LVALUEtoCELL(len)); 31276116Sdcs return; 31376116Sdcs} 31476116Sdcs 31576116Sdcs/************************************************************************** 31676116Sdcs W I D - S E T - N A M E 31776116Sdcs** ficl ( wid c-addr -- ) 31876116Sdcs** Set wid's name pointer to the \0 terminated string address supplied 31976116Sdcs**************************************************************************/ 32076116Sdcsstatic void widSetName(FICL_VM *pVM) 32176116Sdcs{ 32276116Sdcs char *cp = (char *)vmPop(pVM).p; 32376116Sdcs FICL_HASH *pHash = vmPop(pVM).p; 32476116Sdcs pHash->name = cp; 32576116Sdcs return; 32676116Sdcs} 32776116Sdcs 32876116Sdcs 32976116Sdcs/************************************************************************** 33076116Sdcs setParentWid 33176116Sdcs** FICL 33276116Sdcs** setparentwid ( parent-wid wid -- ) 33376116Sdcs** Set WID's link field to the parent-wid. search-wordlist will 33476116Sdcs** iterate through all the links when finding words in the child wid. 33576116Sdcs**************************************************************************/ 33676116Sdcsstatic void setParentWid(FICL_VM *pVM) 33776116Sdcs{ 33876116Sdcs FICL_HASH *parent, *child; 33976116Sdcs#if FICL_ROBUST > 1 34076116Sdcs vmCheckStack(pVM, 2, 0); 34176116Sdcs#endif 34276116Sdcs child = (FICL_HASH *)stackPopPtr(pVM->pStack); 34376116Sdcs parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 34476116Sdcs 34576116Sdcs child->link = parent; 34676116Sdcs return; 34776116Sdcs} 34876116Sdcs 34976116Sdcs 35076116Sdcs/************************************************************************** 35176116Sdcs f i c l C o m p i l e S e a r c h 35276116Sdcs** Builds the primitive wordset and the environment-query namespace. 35376116Sdcs**************************************************************************/ 35476116Sdcs 35576116Sdcsvoid ficlCompileSearch(FICL_SYSTEM *pSys) 35676116Sdcs{ 35776116Sdcs FICL_DICT *dp = pSys->dp; 35876116Sdcs assert (dp); 35976116Sdcs 36076116Sdcs /* 36176116Sdcs ** optional SEARCH-ORDER word set 36276116Sdcs */ 36376116Sdcs dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 36476116Sdcs dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 36576116Sdcs dictAppendWord(dp, "definitions", 36676116Sdcs definitions, FW_DEFAULT); 36776116Sdcs dictAppendWord(dp, "forth-wordlist", 36876116Sdcs forthWordlist, FW_DEFAULT); 36976116Sdcs dictAppendWord(dp, "get-current", 37076116Sdcs getCurrent, FW_DEFAULT); 37176116Sdcs dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 37276116Sdcs dictAppendWord(dp, "search-wordlist", 37376116Sdcs searchWordlist, FW_DEFAULT); 37476116Sdcs dictAppendWord(dp, "set-current", 37576116Sdcs setCurrent, FW_DEFAULT); 37676116Sdcs dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 37776116Sdcs dictAppendWord(dp, "ficl-wordlist", 37876116Sdcs ficlWordlist, FW_DEFAULT); 37976116Sdcs 38076116Sdcs /* 38176116Sdcs ** Set SEARCH environment query values 38276116Sdcs */ 38394290Sdcs ficlSetEnv(pSys, "search-order", FICL_TRUE); 38494290Sdcs ficlSetEnv(pSys, "search-order-ext", FICL_TRUE); 38594290Sdcs ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS); 38676116Sdcs 38776116Sdcs dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT); 38876116Sdcs dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT); 38976116Sdcs dictAppendWord(dp, "wid-set-super", 39076116Sdcs setParentWid, FW_DEFAULT); 39176116Sdcs return; 39276116Sdcs} 39376116Sdcs 394