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 **************************************************************************/
definitions(FICL_VM * pVM)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 **************************************************************************/
forthWordlist(FICL_VM * pVM)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 **************************************************************************/
getCurrent(FICL_VM * pVM)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 **************************************************************************/
getOrder(FICL_VM * pVM)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 **************************************************************************/
searchWordlist(FICL_VM * pVM)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 **************************************************************************/
setCurrent(FICL_VM * pVM)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 **************************************************************************/
setOrder(FICL_VM * pVM)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 **************************************************************************/
ficlWordlist(FICL_VM * pVM)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 **************************************************************************/
searchPop(FICL_VM * pVM)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 **************************************************************************/
searchPush(FICL_VM * pVM)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 **************************************************************************/
widGetName(FICL_VM * pVM)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 **************************************************************************/
widSetName(FICL_VM * pVM)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 **************************************************************************/
setParentWid(FICL_VM * pVM)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
ficlCompileSearch(FICL_SYSTEM * pSys)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
393