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 /* $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