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