1 /*******************************************************************
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 *******************************************************************/
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
20 ** L I C E N S E and D I S C L A I M E R
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
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.
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
50 /**************************************************************************
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)
60 FICL_DICT *pDict = vmGetDict(pVM);
63 if (pDict->nLists < 1)
65 vmThrowErr(pVM, "DEFINITIONS error - empty search order");
68 pDict->pCompile = pDict->pSearch[pDict->nLists-1];
73 /**************************************************************************
74 f o r t h - w o r d l i s t
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)
82 FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
83 stackPushPtr(pVM->pStack, pHash);
88 /**************************************************************************
91 ** Return wid, the identifier of the compilation word list.
92 **************************************************************************/
93 static void getCurrent(FICL_VM *pVM)
95 ficlLockDictionary(TRUE);
96 stackPushPtr(pVM->pStack, vmGetDict(pVM)->pCompile);
97 ficlLockDictionary(FALSE);
102 /**************************************************************************
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)
112 FICL_DICT *pDict = vmGetDict(pVM);
113 int nLists = pDict->nLists;
116 ficlLockDictionary(TRUE);
117 for (i = 0; i < nLists; i++)
119 stackPushPtr(pVM->pStack, pDict->pSearch[i]);
122 stackPushUNS(pVM->pStack, nLists);
123 ficlLockDictionary(FALSE);
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)
141 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
143 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack);
144 si.cp = stackPopPtr(pVM->pStack);
145 hashCode = hashHashCode(si);
147 ficlLockDictionary(TRUE);
148 pFW = hashLookup(pHash, si, hashCode);
149 ficlLockDictionary(FALSE);
153 stackPushPtr(pVM->pStack, pFW);
154 stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
158 stackPushUNS(pVM->pStack, 0);
165 /**************************************************************************
166 s e t - c u r r e n t
168 ** Set the compilation word list to the word list identified by wid.
169 **************************************************************************/
170 static void setCurrent(FICL_VM *pVM)
172 FICL_HASH *pHash = stackPopPtr(pVM->pStack);
173 FICL_DICT *pDict = vmGetDict(pVM);
174 ficlLockDictionary(TRUE);
175 pDict->pCompile = pHash;
176 ficlLockDictionary(FALSE);
181 /**************************************************************************
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)
195 int nLists = stackPopINT(pVM->pStack);
196 FICL_DICT *dp = vmGetDict(pVM);
198 if (nLists > FICL_DEFAULT_VOCS)
200 vmThrowErr(pVM, "set-order error: list would be too large");
203 ficlLockDictionary(TRUE);
208 for (i = nLists-1; i >= 0; --i)
210 dp->pSearch[i] = stackPopPtr(pVM->pStack);
215 dictResetSearchOrder(dp);
218 ficlLockDictionary(FALSE);
223 /**************************************************************************
224 f i c l - w o r d l i s t
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.
232 ** 1. ficl creates a new single-list hash in the dictionary and returns
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)
240 FICL_DICT *dp = vmGetDict(pVM);
245 vmCheckStack(pVM, 1, 1);
247 nBuckets = stackPopUNS(pVM->pStack);
248 pHash = dictCreateWordlist(dp, nBuckets);
249 stackPushPtr(pVM->pStack, pHash);
254 /**************************************************************************
257 ** Pop wid off the search order. Error if the search order is empty
258 **************************************************************************/
259 static void searchPop(FICL_VM *pVM)
261 FICL_DICT *dp = vmGetDict(pVM);
264 ficlLockDictionary(TRUE);
268 vmThrowErr(pVM, "search> error: empty search order");
270 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
271 ficlLockDictionary(FALSE);
276 /**************************************************************************
279 ** Push wid onto the search order. Error if the search order is full.
280 **************************************************************************/
281 static void searchPush(FICL_VM *pVM)
283 FICL_DICT *dp = vmGetDict(pVM);
285 ficlLockDictionary(TRUE);
286 if (dp->nLists > FICL_DEFAULT_VOCS)
288 vmThrowErr(pVM, ">search error: search order overflow");
290 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
291 ficlLockDictionary(FALSE);
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)
303 FICL_HASH *pHash = vmPop(pVM).p;
304 char *cp = pHash->name;
310 vmPush(pVM, LVALUEtoCELL(cp));
311 vmPush(pVM, LVALUEtoCELL(len));
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)
322 char *cp = (char *)vmPop(pVM).p;
323 FICL_HASH *pHash = vmPop(pVM).p;
329 /**************************************************************************
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)
338 FICL_HASH *parent, *child;
340 vmCheckStack(pVM, 2, 0);
342 child = (FICL_HASH *)stackPopPtr(pVM->pStack);
343 parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
345 child->link = parent;
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 **************************************************************************/
355 void ficlCompileSearch(FICL_SYSTEM *pSys)
357 FICL_DICT *dp = pSys->dp;
361 ** optional SEARCH-ORDER word set
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);
381 ** Set SEARCH environment query values
383 ficlSetEnv(pSys, "search-order", FICL_TRUE);
384 ficlSetEnv(pSys, "search-order-ext", FICL_TRUE);
385 ficlSetEnv(pSys, "wordlists", FICL_DEFAULT_VOCS);
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);