stand/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 #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