FreeBSD/Linux Kernel Cross Reference
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
Cache object: 19f263e3e038665d527c5ebff9087eb0
|