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