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 **************************************************************************/ 58 static 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 **************************************************************************/ 80 static 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 **************************************************************************/ 93 static 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 **************************************************************************/ 110 static 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 **************************************************************************/ 136 static 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 **************************************************************************/ 170 static 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 **************************************************************************/ 192 static 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 **************************************************************************/ 238 static 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 **************************************************************************/ 259 static 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 **************************************************************************/ 281 static 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 **************************************************************************/ 301 static 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 **************************************************************************/ 320 static 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 **************************************************************************/ 336 static 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 355 void 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