usr/src/common/ficl/search.c

   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         ficlDictionarySetPrimitive(dictionary, ">search",
 355             ficlPrimitiveSearchPush, FICL_WORD_DEFAULT);
 356         ficlDictionarySetPrimitive(dictionary, "search>",
 357             ficlPrimitiveSearchPop, FICL_WORD_DEFAULT);
 358         ficlDictionarySetPrimitive(dictionary, "definitions",
 359             ficlPrimitiveDefinitions, FICL_WORD_DEFAULT);
 360         ficlDictionarySetPrimitive(dictionary, "forth-wordlist",
 361             ficlPrimitiveForthWordlist, FICL_WORD_DEFAULT);
 362         ficlDictionarySetPrimitive(dictionary, "get-current",
 363             ficlPrimitiveGetCurrent, FICL_WORD_DEFAULT);
 364         ficlDictionarySetPrimitive(dictionary, "get-order",
 365             ficlPrimitiveGetOrder, FICL_WORD_DEFAULT);
 366         ficlDictionarySetPrimitive(dictionary, "search-wordlist",
 367             ficlPrimitiveSearchWordlist, FICL_WORD_DEFAULT);
 368         ficlDictionarySetPrimitive(dictionary, "set-current",
 369             ficlPrimitiveSetCurrent, FICL_WORD_DEFAULT);
 370         ficlDictionarySetPrimitive(dictionary, "set-order",
 371             ficlPrimitiveSetOrder, FICL_WORD_DEFAULT);
 372         ficlDictionarySetPrimitive(dictionary, "ficl-wordlist",
 373             ficlPrimitiveFiclWordlist, FICL_WORD_DEFAULT);
 374
 375         /*
 376          * Set SEARCH environment query values
 377          */
 378         ficlDictionarySetConstant(environment, "search-order", FICL_TRUE);
 379         ficlDictionarySetConstant(environment, "search-order-ext", FICL_TRUE);
 380         ficlDictionarySetConstant(environment, "wordlists", FICL_MAX_WORDLISTS);
 381         ficlDictionarySetPrimitive(dictionary, "wid-get-name",
 382             ficlPrimitiveWidGetName, FICL_WORD_DEFAULT);
 383         ficlDictionarySetPrimitive(dictionary, "wid-set-name",
 384             ficlPrimitiveWidSetName, FICL_WORD_DEFAULT);
 385         ficlDictionarySetPrimitive(dictionary, "wid-set-super",
 386             ficlPrimitiveSetParentWid, FICL_WORD_DEFAULT);
 387 }