1/******************************************************************* 2** s e a r c h . c 3** Forth Inspired Command Language 4** ANS Forth SEARCH and SEARCH-EXT word-set written in C 5** Author: John Sadler (john_sadler@alum.mit.edu) 6** Created: 6 June 2000 7** $Id: search.c,v 1.9 2001/12/05 07:21:34 jsadler Exp $ 8*******************************************************************/ 9/* 10** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 11** All rights reserved. 12** 13** Get the latest Ficl release at http://ficl.sourceforge.net 14** 15** I am interested in hearing from anyone who uses ficl. If you have 16** a problem, a success story, a defect, an enhancement request, or 17** if you would like to contribute to the ficl release, please 18** contact me by email at the address above. 19** 20** L I C E N S E and D I S C L A I M E R 21** 22** Redistribution and use in source and binary forms, with or without 23** modification, are permitted provided that the following conditions 24** are met: 25** 1. Redistributions of source code must retain the above copyright 26** notice, this list of conditions and the following disclaimer. 27** 2. Redistributions in binary form must reproduce the above copyright 28** notice, this list of conditions and the following disclaimer in the 29** documentation and/or other materials provided with the distribution. 30** 31** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 32** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 33** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 34** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 35** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 36** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 37** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 38** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 39** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 40** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 41** SUCH DAMAGE. 42*/ 43 44/* $FreeBSD$ */ 45 46#include <string.h> 47#include "ficl.h" 48#include "math64.h" 49 50/************************************************************************** 51 d e f i n i t i o n s 52** SEARCH ( -- ) 53** Make the compilation word list the same as the first word list in the 54** search order. Specifies that the names of subsequent definitions will 55** be placed in the compilation word list. Subsequent changes in the search 56** order will not affect the compilation word list. 57**************************************************************************/ 58static void definitions(FICL_VM *pVM) 59{ 60 FICL_DICT *pDict = vmGetDict(pVM); 61 62 assert(pDict); 63 if (pDict->nLists < 1) 64 { 65 vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 66 } 67 68 pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 69 return; 70} 71 72 73/************************************************************************** 74 f o r t h - w o r d l i s t 75** SEARCH ( -- wid ) 76** Return wid, the identifier of the word list that includes all standard 77** words provided by the implementation. This word list is initially the 78** compilation word list and is part of the initial search order. 79**************************************************************************/ 80static void forthWordlist(FICL_VM *pVM) 81{ 82 FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; 83 stackPushPtr(pVM->pStack, pHash); 84 return; 85} 86 87 88/************************************************************************** 89 g e t - c u r r e n t 90** SEARCH ( -- wid ) 91** Return wid, the identifier of the compilation word list. 92**************************************************************************/ 93static void getCurrent(FICL_VM *pVM) 94{ 95 ficlLockDictionary(TRUE); 96 stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile); 97 ficlLockDictionary(FALSE); 98 return; 99} 100 101 102/************************************************************************** 103 g e t - o r d e r 104** SEARCH ( -- widn ... wid1 n ) 105** Returns the number of word lists n in the search order and the word list 106** identifiers widn ... wid1 identifying these word lists. wid1 identifies 107** the word list that is searched first, and widn the word list that is 108** searched last. The search order is unaffected. 109**************************************************************************/ 110static void getOrder(FICL_VM *pVM) 111{ 112 FICL_DICT *pDict = vmGetDict(pVM); 113 int nLists = pDict->nLists; 114 int i; 115 116 ficlLockDictionary(TRUE); 117 for (i = 0; i < nLists; i++) 118 { 119 stackPushPtr(pVM->pStack, pDict->pSearch[i]); 120 } 121 122 stackPushUNS(pVM->pStack, nLists); 123 ficlLockDictionary(FALSE); 124 return; 125} 126 127 128/************************************************************************** 129 s e a r c h - w o r d l i s t 130** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 131** Find the definition identified by the string c-addr u in the word list 132** identified by wid. If the definition is not found, return zero. If the 133** definition is found, return its execution token xt and one (1) if the 134** definition is immediate, minus-one (-1) otherwise. 135**************************************************************************/ 136static void searchWordlist(FICL_VM *pVM) 137{ 138 STRINGINFO si; 139 UNS16 hashCode; 140 FICL_WORD *pFW; 141 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 142 143 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 144 si.cp = stackPopPtr(pVM->pStack); 145 hashCode = hashHashCode(si); 146 147 ficlLockDictionary(TRUE); 148 pFW = hashLookup(pHash, si, hashCode); 149 ficlLockDictionary(FALSE); 150 151 if (pFW) 152 { 153 stackPushPtr(pVM->pStack, pFW); 154 stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 155 } 156 else 157 { 158 stackPushUNS(pVM->pStack, 0); 159 } 160 161 return; 162} 163 164 165/************************************************************************** 166 s e t - c u r r e n t 167** SEARCH ( wid -- ) 168** Set the compilation word list to the word list identified by wid. 169**************************************************************************/ 170static void setCurrent(FICL_VM *pVM) 171{ 172 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 173 FICL_DICT *pDict = vmGetDict(pVM); 174 ficlLockDictionary(TRUE); 175 pDict->pCompile = pHash; 176 ficlLockDictionary(FALSE); 177 return; 178} 179 180 181/************************************************************************** 182 s e t - o r d e r 183** SEARCH ( widn ... wid1 n -- ) 184** Set the search order to the word lists identified by widn ... wid1. 185** Subsequently, word list wid1 will be searched first, and word list 186** widn searched last. If n is zero, empty the search order. If n is minus 187** one, set the search order to the implementation-defined minimum 188** search order. The minimum search order shall include the words 189** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 190** be at least eight. 191**************************************************************************/ 192static void setOrder(FICL_VM *pVM) 193{ 194 int i; 195 int nLists = stackPopINT(pVM->pStack); 196 FICL_DICT *dp = vmGetDict(pVM); 197 198 if (nLists > FICL_DEFAULT_VOCS) 199 { 200 vmThrowErr(pVM, "set-order error: list would be too large"); 201 } 202 203 ficlLockDictionary(TRUE); 204 205 if (nLists >= 0) 206 { 207 dp->nLists = nLists; 208 for (i = nLists-1; i >= 0; --i) 209 { 210 dp->pSearch[i] = stackPopPtr(pVM->pStack); 211 } 212 } 213 else 214 { 215 dictResetSearchOrder(dp); 216 } 217 218 ficlLockDictionary(FALSE); 219 return; 220} 221 222 223/************************************************************************** 224 f i c l - w o r d l i s t 225** SEARCH ( -- wid ) 226** Create a new empty word list, returning its word list identifier wid. 227** The new word list may be returned from a pool of preallocated word 228** lists or may be dynamically allocated in data space. A system shall 229** allow the creation of at least 8 new word lists in addition to any 230** provided as part of the system. 231** Notes: 232** 1. ficl creates a new single-list hash in the dictionary and returns 233** its address. 234** 2. ficl-wordlist takes an arg off the stack indicating the number of 235** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 236** : wordlist 1 ficl-wordlist ; 237**************************************************************************/ 238static void ficlWordlist(FICL_VM *pVM) 239{ 240 FICL_DICT *dp = vmGetDict(pVM); 241 FICL_HASH *pHash; 242 FICL_UNS nBuckets; 243 244#if FICL_ROBUST > 1 245 vmCheckStack(pVM, 1, 1); 246#endif 247 nBuckets = stackPopUNS(pVM->pStack); 248 pHash = dictCreateWordlist(dp, nBuckets); 249 stackPushPtr(pVM->pStack, pHash); 250 return; 251} 252 253 254/************************************************************************** 255 S E A R C H > 256** ficl ( -- wid ) 257** Pop wid off the search order. Error if the search order is empty 258**************************************************************************/ 259static void searchPop(FICL_VM *pVM) 260{ 261 FICL_DICT *dp = vmGetDict(pVM); 262 int nLists; 263 264 ficlLockDictionary(TRUE); 265 nLists = dp->nLists; 266 if (nLists == 0) 267 { 268 vmThrowErr(pVM, "search> error: empty search order"); 269 } 270 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 271 ficlLockDictionary(FALSE); 272 return; 273} 274 275 276/************************************************************************** 277 > S E A R C H 278** ficl ( wid -- ) 279** Push wid onto the search order. Error if the search order is full. 280**************************************************************************/ 281static void searchPush(FICL_VM *pVM) 282{ 283 FICL_DICT *dp = vmGetDict(pVM); 284 285 ficlLockDictionary(TRUE); 286 if (dp->nLists > FICL_DEFAULT_VOCS) 287 { 288 vmThrowErr(pVM, ">search error: search order overflow"); 289 } 290 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 291 ficlLockDictionary(FALSE); 292 return; 293} 294 295 296/************************************************************************** 297 W I D - G E T - N A M E 298** ficl ( wid -- c-addr u ) 299** Get wid's (optional) name and push onto stack as a counted string 300**************************************************************************/ 301static void widGetName(FICL_VM *pVM) 302{ 303 FICL_HASH *pHash = vmPop(pVM).p; 304 char *cp = pHash->name; 305 FICL_INT len = 0; 306 307 if (cp) 308 len = strlen(cp); 309 310 vmPush(pVM, LVALUEtoCELL(cp)); 311 vmPush(pVM, LVALUEtoCELL(len)); 312 return; 313} 314 315/************************************************************************** 316 W I D - S E T - N A M E 317** ficl ( wid c-addr -- ) 318** Set wid's name pointer to the \0 terminated string address supplied 319**************************************************************************/ 320static void widSetName(FICL_VM *pVM) 321{ 322 char *cp = (char *)vmPop(pVM).p; 323 FICL_HASH *pHash = vmPop(pVM).p; 324 pHash->name = cp; 325 return; 326} 327 328 329/************************************************************************** 330 setParentWid 331** FICL 332** setparentwid ( parent-wid wid -- ) 333** Set WID's link field to the parent-wid. search-wordlist will 334** iterate through all the links when finding words in the child wid. 335**************************************************************************/ 336static void setParentWid(FICL_VM *pVM) 337{ 338 FICL_HASH *parent, *child; 339#if FICL_ROBUST > 1 340 vmCheckStack(pVM, 2, 0); 341#endif 342 child = (FICL_HASH *)stackPopPtr(pVM->pStack); 343 parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 344 345 child->link = parent; 346 return; 347} 348 349 350/************************************************************************** 351 f i c l C o m p i l e S e a r c h 352** Builds the primitive wordset and the environment-query namespace. 353**************************************************************************/ 354 355void ficlCompileSearch(FICL_SYSTEM *pSys) 356{ 357 FICL_DICT *dp = pSys->dp; 358 assert (dp); 359 360 /* 361 ** optional SEARCH-ORDER word set 362 */ 363 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 364 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 365 dictAppendWord(dp, "definitions", 366 definitions, FW_DEFAULT); 367 dictAppendWord(dp, "forth-wordlist", 368 forthWordlist, FW_DEFAULT); 369 dictAppendWord(dp, "get-current", 370 getCurrent, FW_DEFAULT); 371 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 372 dictAppendWord(dp, "search-wordlist", 373 searchWordlist, FW_DEFAULT); 374 dictAppendWord(dp, "set-current", 375 setCurrent, FW_DEFAULT); 376 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 377 dictAppendWord(dp, "ficl-wordlist", 378 ficlWordlist, FW_DEFAULT); 379 380 /* 381 ** Set SEARCH environment query values 382 */ 383 ficlSetEnv(pSys, "search-order", FICL_TRUE); 384 ficlSetEnv(pSys, "search-order-ext", FICL_TRUE); 385 ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS); 386 387 dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT); 388 dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT); 389 dictAppendWord(dp, "wid-set-super", 390 setParentWid, FW_DEFAULT); 391 return; 392} 393 394