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 45 #include <string.h> 46 #include "ficl.h" 47 #include "math64.h" 48 49 /************************************************************************** 50 d e f i n i t i o n s 51 ** SEARCH ( -- ) 52 ** Make the compilation word list the same as the first word list in the 53 ** search order. Specifies that the names of subsequent definitions will 54 ** be placed in the compilation word list. Subsequent changes in the search 55 ** order will not affect the compilation word list. 56 **************************************************************************/ 57 static void definitions(FICL_VM *pVM) 58 { 59 FICL_DICT *pDict = vmGetDict(pVM); 60 61 assert(pDict); 62 if (pDict->nLists < 1) 63 { 64 vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 65 } 66 67 pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 68 return; 69 } 70 71 72 /************************************************************************** 73 f o r t h - w o r d l i s t 74 ** SEARCH ( -- wid ) 75 ** Return wid, the identifier of the word list that includes all standard 76 ** words provided by the implementation. This word list is initially the 77 ** compilation word list and is part of the initial search order. 78 **************************************************************************/ 79 static void forthWordlist(FICL_VM *pVM) 80 { 81 FICL_HASH *pHash = vmGetDict(pVM)->pForthWords; 82 stackPushPtr(pVM->pStack, pHash); 83 return; 84 } 85 86 87 /************************************************************************** 88 g e t - c u r r e n t 89 ** SEARCH ( -- wid ) 90 ** Return wid, the identifier of the compilation word list. 91 **************************************************************************/ 92 static void getCurrent(FICL_VM *pVM) 93 { 94 ficlLockDictionary(TRUE); 95 stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile); 96 ficlLockDictionary(FALSE); 97 return; 98 } 99 100 101 /************************************************************************** 102 g e t - o r d e r 103 ** SEARCH ( -- widn ... wid1 n ) 104 ** Returns the number of word lists n in the search order and the word list 105 ** identifiers widn ... wid1 identifying these word lists. wid1 identifies 106 ** the word list that is searched first, and widn the word list that is 107 ** searched last. The search order is unaffected. 108 **************************************************************************/ 109 static void getOrder(FICL_VM *pVM) 110 { 111 FICL_DICT *pDict = vmGetDict(pVM); 112 int nLists = pDict->nLists; 113 int i; 114 115 ficlLockDictionary(TRUE); 116 for (i = 0; i < nLists; i++) 117 { 118 stackPushPtr(pVM->pStack, pDict->pSearch[i]); 119 } 120 121 stackPushUNS(pVM->pStack, nLists); 122 ficlLockDictionary(FALSE); 123 return; 124 } 125 126 127 /************************************************************************** 128 s e a r c h - w o r d l i s t 129 ** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 130 ** Find the definition identified by the string c-addr u in the word list 131 ** identified by wid. If the definition is not found, return zero. If the 132 ** definition is found, return its execution token xt and one (1) if the 133 ** definition is immediate, minus-one (-1) otherwise. 134 **************************************************************************/ 135 static void searchWordlist(FICL_VM *pVM) 136 { 137 STRINGINFO si; 138 UNS16 hashCode; 139 FICL_WORD *pFW; 140 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 141 142 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 143 si.cp = stackPopPtr(pVM->pStack); 144 hashCode = hashHashCode(si); 145 146 ficlLockDictionary(TRUE); 147 pFW = hashLookup(pHash, si, hashCode); 148 ficlLockDictionary(FALSE); 149 150 if (pFW) 151 { 152 stackPushPtr(pVM->pStack, pFW); 153 stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 154 } 155 else 156 { 157 stackPushUNS(pVM->pStack, 0); 158 } 159 160 return; 161 } 162 163 164 /************************************************************************** 165 s e t - c u r r e n t 166 ** SEARCH ( wid -- ) 167 ** Set the compilation word list to the word list identified by wid. 168 **************************************************************************/ 169 static void setCurrent(FICL_VM *pVM) 170 { 171 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 172 FICL_DICT *pDict = vmGetDict(pVM); 173 ficlLockDictionary(TRUE); 174 pDict->pCompile = pHash; 175 ficlLockDictionary(FALSE); 176 return; 177 } 178 179 180 /************************************************************************** 181 s e t - o r d e r 182 ** SEARCH ( widn ... wid1 n -- ) 183 ** Set the search order to the word lists identified by widn ... wid1. 184 ** Subsequently, word list wid1 will be searched first, and word list 185 ** widn searched last. If n is zero, empty the search order. If n is minus 186 ** one, set the search order to the implementation-defined minimum 187 ** search order. The minimum search order shall include the words 188 ** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 189 ** be at least eight. 190 **************************************************************************/ 191 static void setOrder(FICL_VM *pVM) 192 { 193 int i; 194 int nLists = stackPopINT(pVM->pStack); 195 FICL_DICT *dp = vmGetDict(pVM); 196 197 if (nLists > FICL_DEFAULT_VOCS) 198 { 199 vmThrowErr(pVM, "set-order error: list would be too large"); 200 } 201 202 ficlLockDictionary(TRUE); 203 204 if (nLists >= 0) 205 { 206 dp->nLists = nLists; 207 for (i = nLists-1; i >= 0; --i) 208 { 209 dp->pSearch[i] = stackPopPtr(pVM->pStack); 210 } 211 } 212 else 213 { 214 dictResetSearchOrder(dp); 215 } 216 217 ficlLockDictionary(FALSE); 218 return; 219 } 220 221 222 /************************************************************************** 223 f i c l - w o r d l i s t 224 ** SEARCH ( -- wid ) 225 ** Create a new empty word list, returning its word list identifier wid. 226 ** The new word list may be returned from a pool of preallocated word 227 ** lists or may be dynamically allocated in data space. A system shall 228 ** allow the creation of at least 8 new word lists in addition to any 229 ** provided as part of the system. 230 ** Notes: 231 ** 1. ficl creates a new single-list hash in the dictionary and returns 232 ** its address. 233 ** 2. ficl-wordlist takes an arg off the stack indicating the number of 234 ** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 235 ** : wordlist 1 ficl-wordlist ; 236 **************************************************************************/ 237 static void ficlWordlist(FICL_VM *pVM) 238 { 239 FICL_DICT *dp = vmGetDict(pVM); 240 FICL_HASH *pHash; 241 FICL_UNS nBuckets; 242 243 #if FICL_ROBUST > 1 244 vmCheckStack(pVM, 1, 1); 245 #endif 246 nBuckets = stackPopUNS(pVM->pStack); 247 pHash = dictCreateWordlist(dp, nBuckets); 248 stackPushPtr(pVM->pStack, pHash); 249 return; 250 } 251 252 253 /************************************************************************** 254 S E A R C H > 255 ** ficl ( -- wid ) 256 ** Pop wid off the search order. Error if the search order is empty 257 **************************************************************************/ 258 static void searchPop(FICL_VM *pVM) 259 { 260 FICL_DICT *dp = vmGetDict(pVM); 261 int nLists; 262 263 ficlLockDictionary(TRUE); 264 nLists = dp->nLists; 265 if (nLists == 0) 266 { 267 vmThrowErr(pVM, "search> error: empty search order"); 268 } 269 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 270 ficlLockDictionary(FALSE); 271 return; 272 } 273 274 275 /************************************************************************** 276 > S E A R C H 277 ** ficl ( wid -- ) 278 ** Push wid onto the search order. Error if the search order is full. 279 **************************************************************************/ 280 static void searchPush(FICL_VM *pVM) 281 { 282 FICL_DICT *dp = vmGetDict(pVM); 283 284 ficlLockDictionary(TRUE); 285 if (dp->nLists > FICL_DEFAULT_VOCS) 286 { 287 vmThrowErr(pVM, ">search error: search order overflow"); 288 } 289 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 290 ficlLockDictionary(FALSE); 291 return; 292 } 293 294 295 /************************************************************************** 296 W I D - G E T - N A M E 297 ** ficl ( wid -- c-addr u ) 298 ** Get wid's (optional) name and push onto stack as a counted string 299 **************************************************************************/ 300 static void widGetName(FICL_VM *pVM) 301 { 302 FICL_HASH *pHash = vmPop(pVM).p; 303 char *cp = pHash->name; 304 FICL_INT len = 0; 305 306 if (cp) 307 len = strlen(cp); 308 309 vmPush(pVM, LVALUEtoCELL(cp)); 310 vmPush(pVM, LVALUEtoCELL(len)); 311 return; 312 } 313 314 /************************************************************************** 315 W I D - S E T - N A M E 316 ** ficl ( wid c-addr -- ) 317 ** Set wid's name pointer to the \0 terminated string address supplied 318 **************************************************************************/ 319 static void widSetName(FICL_VM *pVM) 320 { 321 char *cp = (char *)vmPop(pVM).p; 322 FICL_HASH *pHash = vmPop(pVM).p; 323 pHash->name = cp; 324 return; 325 } 326 327 328 /************************************************************************** 329 setParentWid 330 ** FICL 331 ** setparentwid ( parent-wid wid -- ) 332 ** Set WID's link field to the parent-wid. search-wordlist will 333 ** iterate through all the links when finding words in the child wid. 334 **************************************************************************/ 335 static void setParentWid(FICL_VM *pVM) 336 { 337 FICL_HASH *parent, *child; 338 #if FICL_ROBUST > 1 339 vmCheckStack(pVM, 2, 0); 340 #endif 341 child = (FICL_HASH *)stackPopPtr(pVM->pStack); 342 parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 343 344 child->link = parent; 345 return; 346 } 347 348 349 /************************************************************************** 350 f i c l C o m p i l e S e a r c h 351 ** Builds the primitive wordset and the environment-query namespace. 352 **************************************************************************/ 353 354 void ficlCompileSearch(FICL_SYSTEM *pSys) 355 { 356 FICL_DICT *dp = pSys->dp; 357 assert (dp); 358 359 /* 360 ** optional SEARCH-ORDER word set 361 */ 362 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 363 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 364 dictAppendWord(dp, "definitions", 365 definitions, FW_DEFAULT); 366 dictAppendWord(dp, "forth-wordlist", 367 forthWordlist, FW_DEFAULT); 368 dictAppendWord(dp, "get-current", 369 getCurrent, FW_DEFAULT); 370 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 371 dictAppendWord(dp, "search-wordlist", 372 searchWordlist, FW_DEFAULT); 373 dictAppendWord(dp, "set-current", 374 setCurrent, FW_DEFAULT); 375 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 376 dictAppendWord(dp, "ficl-wordlist", 377 ficlWordlist, FW_DEFAULT); 378 379 /* 380 ** Set SEARCH environment query values 381 */ 382 ficlSetEnv(pSys, "search-order", FICL_TRUE); 383 ficlSetEnv(pSys, "search-order-ext", FICL_TRUE); 384 ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS); 385 386 dictAppendWord(dp, "wid-get-name", widGetName, FW_DEFAULT); 387 dictAppendWord(dp, "wid-set-name", widSetName, FW_DEFAULT); 388 dictAppendWord(dp, "wid-set-super", 389 setParentWid, FW_DEFAULT); 390 return; 391 } 392 393